Удаление элементов в массиве, если элемент является определенным значением VBA

Question

У меня есть глобальный массив, 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 Macro

Answer 1

Массив - это структура определенного размера.Вы можете использовать динамические массивы в VBA, которые вы можете уменьшить или увеличить с помощью ReDim, но вы не можете удалить элементы в середине.Из вашего примера неясно, как функционально работает ваш массив или как вы определяете позицию индекса (eachHdr), но у вас в основном есть 3 варианта

(A) Напишите пользовательскую функцию «delete» для вашего массива, как (не проверено)

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.Коллекция.Коллекция представляет собой (уникальную) структуру пары ключ / значение, в которой вы можете свободно добавлять или удалять элементы из

Dim prLst As New Collection

Answer 2

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

Answer 3

Все просто.Я сделал это следующим образом, чтобы получить строку с уникальными значениями (из двух столбцов выходного листа):

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

Answer 4

Я знаю, что это старое, но вот решение, которое я придумал, когда мне не понравились найденные.

-Переход по массиву (вариант), добавляющий каждый элемент и некоторый разделитель кстрока, если она не совпадает с той, которую вы хотите удалить. - Затем разделите строку на разделителе

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

Очевидно, что использование строк создает некоторые ограничения, например, необходимость быть уверенной в информации, уже находящейся в массиве,и как этот код делает первый элемент массива пустым, но он делает то, что мне нужно, и немного больше работы может сделать его более универсальным.

Answer 5

- это пример кода, использующего функцию 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

Answer 6

Удаление элементов в массиве, если элемент является определенным значением 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, ",")

Я часто манипулирую 1D-массивом с помощью Join / Split но если вам нужно удалить определенное значение в многомерном измерении, я предлагаю вам изменить эти массивы на 1D-массивы, как это

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.

Answer 7

Я довольно новичок в 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

Использование кучи сообщений для отладки банкомата - я уверен, что вы измените ее в соответствии со своей работой.

Я надеюсь, что люди найдут это полезным, С уважением Джо

Answer 8

При создании массива, почему бы просто не пропустить нули и сэкономить время, чтобы потом беспокоиться о них? Как упоминалось выше, массивы не подходят для удаления.