Löschen von Elementen in einem Array, wenn das Element einen Bestimmten Wert mit VBA

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

Ich bin Recht neu in vba & excel - nur tun Sie dies für etwa 3 Monate -
Ich dachte, ich würde teilen meine array-Deduplizierung Methode, da dieser post scheint relevant zu:

Diesen code, wenn Sie Teil einer größeren Anwendung, die Analysen Rohr-Daten-
Die Rohre sind aufgelistet in der ein Blatt mit der Nummer in xxxx.1, xxxx.2, yyyy.1, yyyy.2 .... format. so thats, warum alle string-manipulation vorhanden ist.
im Grunde ist es nur speichert der pipe-Nummer nur einmal, und nicht die .2 oder .1 Teil.

        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

Mit einem Haufen von message-Boxen für debugging-atm - ich bin sicher, Sie werden ändern Sie es für Ihre eigene Arbeit.

Ich hoffe, die Leute finden diese hilfreich,
Grüße
Joe

hier ist ein Beispiel von code mithilfe der CopyMemory Funktion, die Arbeit zu tun.

Ist es angeblich "viel schneller" (abhängig von der Größe und Typ des Arrays...).

ich bin nicht der Autor, aber ich habe es getestet :

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

Ist es einfach. Ich Tat es den folgenden Weg, um eine Zeichenfolge mit einzigartigen Werte (aus zwei Spalten einer 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