首页 文章

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

提问于
浏览 次
11

我有一个可变长度的全局数组 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 中的元素？

NOTE: 这是一个较大的程序的一部分，其描述可以在这里找到：Sorting Groups of Rows Excel VBA Macro

arrays excel vba element

8 回答

  • 0

    数组是具有一定大小的结构 . 您可以在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(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
    回复于
  • 31
    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
    回复于
  • 0

    在创建数组时，为什么不跳过0并节省自己以后担心它们的时间？如上所述，数组不适合删除 .

    回复于
  • 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, ":-:")

    显然，字符串的使用会产生一些限制，比如需要确定数组中已有的信息，而且这个代码会使第一个数组元素变成空白，但是它会做我需要的东西，并且可以做更多的工作 . 更多才多艺 .

    回复于
  • 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
    回复于
  • 1

    这是使用 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和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

    使用一堆消息框进行调试 - 确保您将更改它以适合您自己的工作 .

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

    回复于
  • 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中删除某些值，我建议你将这些数组更改为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.
    回复于

相关问题