要素が特定の値の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マクロ
配列は、特定のサイズの構造体です。 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
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
私は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のデバッグにメッセージボックスのヒープを使用する-自分の作業に合わせて変更してください。
ジョーよろしくお願いします。
私はこれが古いことを知っていますが、見つけたものが気に入らなかったときに思いついた解決策があります。
-配列（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, ":-:")
明らかに、文字列を使用すると、すでに配列にある情報を確認する必要があるなど、いくつかの制限が生じます。また、このコードでは、最初の配列要素が空白になりますが、より汎用性があります。
以下は、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
要素が特定の値の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.
簡単です。 （出力シートの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をスキップして、後でそれらを心配する時間を節約してみませんか？前述のように、配列は削除に適していません。