web-dev-qa-db-ja.com

要素が特定の値のVBAである場合の配列内の要素の削除

可変長のグローバル配列prLst()があります。数字を文字列_"1"_からUbound(prLst)として受け取ります。ただし、ユーザーが_"0"_を入力したら、リストからその要素を削除します。これを実行するために記述された次のコードがあります。

_count2 = 0
eachHdr = 1
totHead = UBound(prLst)

Do
    If prLst(eachHdr) = "0" Then
        prLst(eachHdr).Delete
        count2 = count2 + 1
    End If
    keepTrack = totHead - count2
    'MsgBox "prLst = " & prLst(eachHdr)
    eachHdr = eachHdr + 1
Loop Until eachHdr > keepTrack
_

これは動作しません。要素が_"0"_の場合、配列prLstの要素を効率的に削除するにはどうすればよいですか?


注:これはより大きなプログラムの一部であり、その説明はここにあります: 行のグループの並べ替えExcel VBAマクロ

13
H3lue

配列は、特定のサイズの構造体です。 ReDimを使用して縮小または拡大できるvbaの動的配列を使用できますが、途中の要素は削除できません。サンプルからは、配列がどのように機能するか、またはインデックス位置(eachHdr)をどのように決定するかはサンプルから明らかではありませんが、基本的に3つのオプションがあります

(A)(未テスト)のように、配列のカスタム「削除」関数を記述します

Public Sub DeleteElementAt(Byval index As Integer, Byref prLst as Variant)
       Dim i As Integer

        ' Move all element back one position
        For i = index + 1 To UBound(prLst)
            prLst(i - 1) = prLst(i)
        Next

        ' Shrink the array by one, removing the last one
        ReDim Preserve prLst(Len(prLst) - 1)
End Sub

(B)要素を実際に削除するのではなく、単に「ダミー」値を値として設定する

If prLst(eachHdr) = "0" Then        
   prLst(eachHdr) = "n/a"
End If

(C)配列の使用を停止し、VBA.Collectionに変更します。コレクションは、要素を自由に追加または削除できる(一意の)キー/値ペア構造です

Dim prLst As New Collection
34
Eddy
Sub DelEle(Ary, SameTypeTemp, Index As Integer) '<<<<<<<<< pass only not fixed sized array (i don't know how to declare same type temp array in proceder)
    Dim I As Integer, II As Integer
    II = -1
    If Index < LBound(Ary) And Index > UBound(Ary) Then MsgBox "Error.........."
    For I = 0 To UBound(Ary)
        If I <> Index Then
            II = II + 1
            ReDim Preserve SameTypeTemp(II)
            SameTypeTemp(II) = Ary(I)
        End If
    Next I
    ReDim Ary(UBound(SameTypeTemp))
    Ary = SameTypeTemp
    Erase SameTypeTemp
End Sub

Sub Test()
    Dim a() As Integer, b() As Integer
    ReDim a(3)
    Debug.Print "InputData:"
    For I = 0 To UBound(a)
        a(I) = I
        Debug.Print "    " & a(I)
    Next
    DelEle a, b, 1
    Debug.Print "Result:"
    For I = 0 To UBound(a)
        Debug.Print "    " & a(I)
    Next
End Sub
1
K. Gunman

私はvbaとExcelにかなり慣れていない-これを約3ヶ月間だけやっている-この投稿がそれに関連しているように見えるので、ここで私の配列重複排除方法を共有すると思った:

パイプデータを分析するより大きなアプリケーションの一部である場合、このコード-パイプは、xxxx.1、xxxx.2、yyyy.1、yyyy.2 ....形式の番号のシートにリストされます。これが、すべての文字列操作が存在する理由です。基本的に、パイプ番号は一度だけ収集され、.2または.1の部分は収集されません。

        With wbPreviousSummary.Sheets(1)
'   here, we will write the edited pipe numbers to a collection - then pass the collection to an array
        Dim PipeDict As New Dictionary

        Dim TempArray As Variant

        TempArray = .Range(.Cells(3, 2), .Cells(3, 2).End(xlDown)).Value

        For ele = LBound(TempArray, 1) To UBound(TempArray, 1)

            If Not PipeDict.Exists(Left(TempArray(ele, 1), Len(TempArray(ele, 1) - 2))) Then

                PipeDict.Add Key:=Left(TempArray(ele, 1), Len(TempArray(ele, 1) - 2)), _
                                                        Item:=Left(TempArray(ele, 1), Len(TempArray(ele, 1) - 2))

            End If

        Next ele

        TempArray = PipeDict.Items

        For ele = LBound(TempArray) To UBound(TempArray)
            MsgBox TempArray(ele)
        Next ele

    End With
    wbPreviousSummary.Close SaveChanges:=False

    Set wbPreviousSummary = Nothing 'done early so we dont have the information loaded in memory

ATMのデバッグにメッセージボックスのヒープを使用する-自分の作業に合わせて変更してください。

ジョーよろしくお願いします。

0
AverageJoe

私はこれが古いことを知っていますが、見つけたものが気に入らなかったときに思いついた解決策があります。

-配列(Variant)をループして、各要素といくつかの仕切りを文字列に追加します(削除するものと一致しない場合)-次に、仕切りで文字列を分割します

tmpString=""
For Each arrElem in GlobalArray
   If CStr(arrElem) = "removeThis" Then
      GoTo SkipElem
   Else
      tmpString =tmpString & ":-:" & CStr(arrElem)
   End If
SkipElem:
Next
GlobalArray = Split(tmpString, ":-:")

明らかに、文字列を使用すると、すでに配列にある情報を確認する必要があるなど、いくつかの制限が生じます。また、このコードでは、最初の配列要素が空白になりますが、より汎用性があります。

0
charles_m80

以下は、CopyMemory関数を使用してジョブを実行するコードのサンプルです。

おそらく「はるかに高速」です(配列のサイズとタイプによって異なります)。

私は著者ではありませんが、テストしました:

Sub RemoveArrayElement_Str(ByRef AryVar() As String, ByVal RemoveWhich As Long) 

'// The size of the array elements
'// In the case of string arrays, they are
'// simply 32 bit pointers to BSTR's.
Dim byteLen As Byte

'// String pointers are 4 bytes
byteLen = 4

'// The copymemory operation is not necessary unless
'// we are working with an array element that is not
'// at the end of the array
If RemoveWhich < UBound(AryVar) Then
    '// Copy the block of string pointers starting at
    ' the position after the
    '// removed item back one spot.
    CopyMemory ByVal VarPtr(AryVar(RemoveWhich)), ByVal _
        VarPtr(AryVar(RemoveWhich + 1)), (byteLen) * _
        (UBound(AryVar) - RemoveWhich)
End If

'// If we are removing the last array element
'// just deinitialize the array
'// otherwise chop the array down by one.
If UBound(AryVar) = LBound(AryVar) Then
    Erase AryVar
Else
    ReDim Preserve AryVar(LBound(AryVar) To UBound(AryVar) - 1)
End If
End Sub
0

要素が特定の値のVBAである場合の配列内の要素の削除

特定の条件で配列の要素を削除するには、次のようにコーディングできます

For i = LBound(ArrValue, 2) To UBound(ArrValue, 2)
    If [Certain condition] Then
        ArrValue(1, i) = "-----------------------"
    End If
Next i

StrTransfer = Replace(Replace(Replace(join(Application.Index(ArrValue(), 1, 0), ","), ",-----------------------,", ",", , , vbBinaryCompare), "-----------------------,", "", , , vbBinaryCompare), ",-----------------------", "", , , vbBinaryCompare)
ResultArray = join( Strtransfer, ",")

Join/Splitで1D-Arrayを操作することがよくありますが、Multi Dimensionで特定の値を削除する必要がある場合は、これらのArrayをこのように1D-Arrayに変更することをお勧めします

strTransfer = Replace(Replace(Replace(Replace(Names.Add("A", MultiDimensionArray), Chr(34), ""), "={", ""), "}", ""), ";", ",")
'somecode to edit Array like 1st code on top of this comment
'then loop through this strTransfer to get right value in right dimension
'with split function.
0
Hv summer

簡単です。 (出力シートの2つの列から)一意の値を持つ文字列を取得するには、次の方法で行いました。

Dim startpoint, endpoint, ArrCount As Integer
Dim SentToArr() As String

'created by running the first part (check for new entries)
startpoint = ThisWorkbook.Sheets("temp").Range("A1").Value
'set counter on 0
Arrcount = 0 
'last filled row in BG
endpoint = ThisWorkbook.Sheets("BG").Range("G1047854").End(xlUp).Row

'create arr with all data - this could be any data you want!
With ThisWorkbook.Sheets("BG")
    For i = startpoint To endpoint
        ArrCount = ArrCount + 1
        ReDim Preserve SentToArr(1 To ArrCount)
        SentToArr(ArrCount) = .Range("A" & i).Value
        'get prep
        ArrCount = ArrCount + 1
        ReDim Preserve SentToArr(1 To ArrCount)
        SentToArr(ArrCount) = .Range("B" & i).Value
    Next i
End With

'iterate the arr and get a key (l) in each iteration
For l = LBound(SentToArr) To UBound(SentToArr)
    Key = SentToArr(l)
    'iterate one more time and compare the first key (l) with key (k)
    For k = LBound(SentToArr) To UBound(SentToArr)
        'if key = the new key from the second iteration and the position is different fill it as empty
        If Key = SentToArr(k) And Not k = l Then
            SentToArr(k) = ""
        End If
    Next k
Next l

'iterate through all 'unique-made' values, if the value of the pos is 
'empty, skip - you could also create a new array by using the following after the IF below - !! dont forget to reset [ArrCount] as well:
'ArrCount = ArrCount + 1
'ReDim Preserve SentToArr(1 To ArrCount)
'SentToArr(ArrCount) = SentToArr(h)

For h = LBound(SentToArr) To UBound(SentToArr)
    If SentToArr(h) = "" Then GoTo skipArrayPart
    GetEmailArray = GetEmailArray & "; " & SentToArr(h)
skipArrayPart:
Next h

'some clean up
If Left(GetEmailArray, 2) = "; " Then
    GetEmailArray = Right(GetEmailArray, Len(GetEmailArray) - 2)
End If

'show us the money
MsgBox GetEmailArray
0
ko_00

配列を作成するときに、0をスキップして、後でそれらを心配する時間を節約してみませんか?前述のように、配列は削除に適していません。

0
aevanko