如果元素是某个值 VBA，则删除数组中的元素

Deleting Elements in an Array if Element is a Certain value VBA

提问by H3lue

I have a global array, prLst()that can of variable length. It takes in numbers as strings "1"to Ubound(prLst). However, when the user enters "0", I want to delete that element from the list. I have the following code written to perform this:

我有一个全局数组，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

This does not work. How do I efficiently delete elements in the array prLstif the element is "0"?

这不起作用。prLst如果元素是 ，我如何有效地删除数组中的元素"0"？

---

---

NOTE:This is part of a larger program, for which the description of can be found here: Sorting Groups of Rows Excel VBA Macro

注意：这是一个更大的程序的一部分，可以在这里找到它的描述：Sorting Groups of Rows Excel VBA Macro

回答by Eddy

An array is a structure with a certain size. You can use dynamic arrays in vba that you can shrink or grow using ReDim but you can't remove elements in the middle. It's not clear from your sample how your array functionally works or how you determine the index position (eachHdr) but you basically have 3 options

数组是具有一定大小的结构。您可以在 vba 中使用动态数组，您可以使用 ReDim 缩小或增长这些数组，但不能删除中间的元素。从您的示例中不清楚您的数组如何工作或您如何确定索引位置（eachHdr），但您基本上有 3 个选项

(A) Write a custom 'delete' function for your array like (untested)

(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) Simply set a 'dummy' value as the value instead of actually deleting the element

(B) 只需将“虚拟”值设置为值，而不是实际删除元素

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

(C) Stop using an array and change it into a VBA.Collection. A collection is a (unique)key/value pair structure where you can freely add or delete elements from

(C) 停止使用数组并将其更改为 VBA.Collection。集合是一个（唯一的）键/值对结构，您可以在其中自由添加或删除元素

Dim prLst As New Collection

回答by Patrick Lepelletier

here is a sample of code using the CopyMemoryfunction to do the job.

这是使用该CopyMemory函数完成工作的代码示例。

It is supposedly "much faster" (depending of the size and type of the array...).

据说它“快得多”（取决于数组的大小和类型......）。

i am not the author, but i tested it :

我不是作者，但我测试了它：

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

回答by K. Gunman

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

回答by Hv summer

Deleting Elements in an Array if Element is a Certain value VBA

如果元素是某个值 VBA，则删除数组中的元素

to delete elements in an Array wih certain condition, you can code like this

要在特定条件下删除数组中的元素，您可以这样编码

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, ",")

I often manipulate 1D-Array with Join/Split but if you have to delete certain value in Multi Dimension I suggest you to change those Array into 1D-Array like this

我经常使用 Join/Split 操作一维数组，但如果你必须删除多维中的某些值，我建议你像这样将这些数组更改为一维数组

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.

回答by aevanko

When creating the array, why not just skip over the 0s and save yourself the time of having to worry about them later? As mentioned above, arrays are not well-suited for deletion.

在创建数组时，为什么不直接跳过 0 并节省您以后不必担心它们的时间？如上所述，数组不太适合删除。

回答by AverageJoe

I'm pretty new to vba & excel - only been doing this for about 3 months - I thought I'd share my array de-duplication method here as this post seems relevant to it:

我对 vba 和 excel 很陌生——只做了大约 3 个月——我想我会在这里分享我的数组重复数据删除方法，因为这篇文章似乎与它相关：

This code if part of a bigger application that analyses pipe data- Pipes are listed in a sheet with number in xxxx.1, xxxx.2, yyyy.1, yyyy.2 .... format. so thats why all the string manipulation exists. basically it only collects the pipe number once only, and not the .2 or .1 part.

此代码是分析管道数据的较大应用程序的一部分 - 管道列在表格中，编号为 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

Using a heap of message boxes for debugging atm - im sure you'll change it to suit your own work.

使用一堆消息框来调试 atm - 我相信你会改变它以适合你自己的工作。

I hope people find this useful, Regards Joe

我希望人们觉得这很有用，问候乔

回答by charles_m80

I know this is old, but here's the solution I came up with when I didn't like the ones I found.

我知道这已经过时了，但是当我不喜欢我找到的那些时，这是我想出的解决方案。

-Loop through the array (Variant) adding each element and some divider to a string, unless it matches the one you want to remove -Then split the string on the divider

- 遍历数组 (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, ":-:")

Obviously the use of strings creates some limitations, like needing to be sure of the information already in the array, and as-is this code makes the first array element blank, but it does what I need and with a little more work it could be more versatile.

显然，字符串的使用会产生一些限制，例如需要确保数组中已有的信息，并且此代码使第一个数组元素为空，但它可以满足我的需要，并且可以做更多的工作更通用。

回答by ko_00

It's simple. I did it the following way to get a string with unique values (from two columns of an output sheet):

这很简单。我通过以下方式获取具有唯一值的字符串（来自输出表的两列）：

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