2-dimensionales Array: Doppelte "Zeilen" löschen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

HAllo
Sowas könnte funktionieren.

Option Explicit

Public Sub aufruf()
    Call test(deinarray)
End Sub

Public Sub test(arr)
    Dim L As Long
    Dim i As Integer
    Dim myDic As Object
    Dim strTmp As String
    Const Dummy As String = vbTab
    Set myDic = CreateObject("Scripting.Dictionary")
    For L = LBound(arr) To UBound(arr)
        strTmp = ""
        For i = LBound(arr, 2) To UBound(arr, 2)
            strTmp = strTmp & arr(L, i) & Dummy
        Next
        myDic(strTmp) = 0
    Next
    schreiben (Join(myDic.keys, vbCrLf))
    With Sheets("tabelle2")
        .Paste .Range("A1")
    End With
End Sub

Public Sub schreiben(DerText As String)
    Dim IE As Object
    Set IE = CreateObject("HTMLfile")
    IE.ParentWindow.ClipboardData.SetData "text", DerText & vbNullString
    Set IE = Nothing
End Sub

Ein kleiner Testlauf sah recht gut gut aus.
ransi

Function TwinKiller(SourceArr As Variant) As Variant Dim i As Long, j As Long Dim Twin As Boolean Dim TempArr As Variant ReDim TempArr(LBound(SourceArr, 2) To UBound(SourceArr, 2), LBound(SourceArr, 1) To LBound( _ SourceArr, 1)) 'Erste Zeile übertragen For i = LBound(SourceArr, 2) To UBound(SourceArr, 2) TempArr(i, LBound(SourceArr, 1)) = SourceArr(LBound(SourceArr, 1), i) Next i 'Vergleich mit vorherigem Datensatz For i = LBound(SourceArr, 1) + 1 To UBound(SourceArr, 1) Twin = True 'Zeilenweise vergleichen For j = LBound(SourceArr, 2) To UBound(SourceArr, 2) If SourceArr(i, j) SourceArr(i - 1, j) Then Twin = False Exit For End If Next j 'Nicht-Doppelte übernehmen If Twin = False Then ReDim Preserve TempArr(LBound(TempArr, 1) To UBound(TempArr, 1), LBound(TempArr, 2) _ To UBound(TempArr, 2) + 1) For j = LBound(SourceArr, 2) To UBound(SourceArr, 2) TempArr(j, UBound(TempArr, 2)) = SourceArr(i, j) Next j End If Next i TwinKiller = Application.Transpose(TempArr) End Function

Function TwinKiller(arr) As Variant Dim L As Long Dim i As Integer Dim myDic As Object Dim strTmp As String Const Dummy As String = vbTab Set myDic = CreateObject("Scripting.Dictionary") For L = LBound(arr) To UBound(arr) strTmp = "" For i = LBound(arr, 2) To UBound(arr, 2) strTmp = strTmp & arr(L, i) & Dummy Next myDic(strTmp) = 0 Next 'Rückgabe an Array Dim RowArr As Variant Dim ColArr As Variant RowArr = Split((Join(myDic.keys, vbCrLf)), vbCrLf) ColArr = Split(RowArr(0), Dummy) ReDim arr(0 To UBound(RowArr), 0 To UBound(ColArr) - 1) For L = 0 To UBound(RowArr) ColArr = Split(RowArr(L), Dummy) For i = 0 To UBound(ColArr) - 1 arr(L, i) = ColArr(i) Next Next TwinKiller = arr End Function

Hallo,
ich bin es schon wieder. Ich habe mir überlegt, dass ich auch den letzten "Störfaktor" beseitigen sollte: Jetzt bleiben die Anfangswerte der beiden Array-Dimensionen auch nach dem Durchlauf der Function unverändert. Der Endwert der zweiten Dimension bleibt demzufolge ebenfalls unverändert. Der Endwert der ersten Dimension ändert sich in Abhängigkeit der gefundenen Wiederholungen.
Hier nun der neue VBA-Code:


Function TwinKiller(arr) As Variant
Dim L As Long
Dim i As Integer
Dim myDic As Object
Dim strTmp As String
Const Dummy As String = vbTab
Set myDic = CreateObject("Scripting.Dictionary")
For L = LBound(arr) To UBound(arr)
strTmp = ""
For i = LBound(arr, 2) To UBound(arr, 2)
strTmp = strTmp & arr(L, i) & Dummy
Next
myDic(strTmp) = 0
Next
'Rückgabe an Array
Dim RowArr As Variant, ColArr As Variant
Dim RowDif As Long, ColDif As Long
RowDif = LBound(arr, 1)
ColDif = LBound(arr, 2)
RowArr = Split((Join(myDic.keys, vbCrLf)), vbCrLf)
ColArr = Split(RowArr(0), Dummy)
ReDim arr(0 + RowDif To UBound(RowArr) + RowDif, 0 + ColDif To UBound(ColArr) + ColDif - 1)
For L = 0 To UBound(RowArr)
ColArr = Split(RowArr(L), Dummy)
For i = 0 To UBound(ColArr) - 1
arr(L + RowDif, i + ColDif) = ColArr(i)
Next
Next
TwinKiller = arr
End Function

Sollte jemand Doppelungen in der zweiten Array-Dimension (also doppelte Spalten) löschen wollen, _ so kann er den Code oben ebenfalls verwenden. Jedoch sollte die Function dann wiefolgt aufgerufen werden:


Sub ColTwinKiller()
TestArray = Application.Transpose(TestArray)
Call TwinKiller(TestArray)
TestArray = Application.Transpose(TestArray)
End Sub

Viel Spaß!
Martin

Function TwinKiller(arr) As Variant Dim L As Long Dim i As Integer Dim myDic As Object Dim strTmp As String Const Dummy As String = vbTab Set myDic = CreateObject("Scripting.Dictionary") For L = LBound(arr) To UBound(arr) strTmp = "" For i = LBound(arr, 2) To UBound(arr, 2) strTmp = strTmp & arr(L, i) & Dummy Next myDic(strTmp) = 0 Next 'Rückgabe an Array Dim RowArr As Variant, ColArr As Variant Dim RowDif As Long, ColDif As Long RowDif = LBound(arr, 1) ColDif = LBound(arr, 2) RowArr = myDic.keys ColArr = Split(RowArr(0), Dummy) ReDim arr(RowDif To UBound(RowArr) + RowDif, ColDif To UBound(ColArr) + ColDif - 1) For L = 0 To UBound(RowArr) ColArr = Split(RowArr(L), Dummy) For i = 0 To UBound(ColArr) - 1 arr(L + RowDif, i + ColDif) = ColArr(i) Next Next TwinKiller = arr End Function

Beliebteste Forumthreads (12 Monate)

2-dimensionales Array: Doppelte "Zeilen" löschen

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2-dimensionales Array: Doppelte "Zeilen" löschen

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread