在VBA中，如果数组元素是特定值，可以删除数组中的元素。

Question

在VBA中，如果数组元素是特定值，可以删除数组中的元素。

18

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

这个方法不起作用。如果数组prLst的元素是"0"，我该如何高效地删除它们？

注意：这是一个更大程序的一部分，其描述可以在这里找到：Excel VBA宏对行分组排序

- H3lue

这可能对您的使用情况没有帮助，但如果这是一个工作表函数，您可以使用FILTER()从数组中删除零。 - user7868

8个回答

2

以下是使用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

- Patrick Lepelletier

1

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

- K. Gunman

5

仅有代码的答案很少是好的。最好加上一些解释性文字来说明它。 - PC Luddite

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来操作一维数组，但如果你需要删除多维数组中的某些值，我建议你将这些数组转换为一维数组，像这样：

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.

- Hv summer

0

我知道这个方法有点老了，但是当我不喜欢找到的其他方法时，我想出了一个解决方案。

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

显然，使用字符串会带来一些限制，比如需要确保数组中已有的信息，而且这段代码使第一个数组元素为空白，但它做到了我需要的功能，再加上一点点工作，它就可以更加通用。

- charles_m80

不错且简单的方法。但需要稍微调整一下，因为数组的第一个值始终会自动为空白。 - user2385809

0

很简单。我是通过以下方式获取一个包含唯一值的字符串（从输出表的两列中）：

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

- ko_00

0

我对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

目前使用一堆消息框进行调试 - 我相信你会根据自己的工作进行更改。

我希望人们会发现这个有用，敬礼乔

- AverageJoe

请不要运行那段代码——缺少很多变量，而且我发布时有些字符串处理是错误的。 - AverageJoe

0

创建数组时，为什么不直接跳过0并节省后续的麻烦呢？正如上面提到的，数组并不适合删除操作。

- Gaijinhunter

这段代码是我正在创建的更大代码的一部分，可以在这里找到：https://dev59.com/HlnUa4cB1Zd3GeqPXyzy。此代码是子程序EstSortPriorities的一部分。因为程序不知道哪些标题应该在表格顶部排序，所以用户必须指定。我选择让用户在给定特定标题时输入“0”表示不需要排序优先级。 - H3lue

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- Eddy · Accepted Answer

数组是一种具有特定大小的结构。在VBA中，您可以使用动态数组，可以使用ReDim缩小或增大数组的大小，但无法删除中间元素。从示例中不清楚您的数组如何工作或如何确定索引位置（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(LBound(prLst) To UBound(prLst) - 1)
End Sub

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

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

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

Dim prLst As New Collection