Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

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

2-dimensionales Array: Doppelte "Zeilen" löschen
Martin
Hallo,
ich lese aus dem Internet etwa 7650 Zeilen mit 13 Spalten in ein Array in Excel ein, was auch sehr gut klappt. Leider kommen einige Zeilen doppelt vor, die ich daher gerne aus dem Array löschen würde. Kennt von Euch jemand eine Function, die alle doppelten Zeilen eines 2-dimensionalen Array löscht und könnte mir diese hier posten? Für Antworten wäre ich sehr dankbar.
Viele Grüße
Martin
AW: 2-dimensionales Array: Doppelte "Zeilen" löschen
20.11.2010 15:23:58
ransi
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
Anzeige
AW: 2-dimensionales Array: Doppelte "Zeilen" löschen
20.11.2010 17:21:28
Martin
Hallo Ransi,
vielen Dank für deine Antwort. Ich hatte vergessen die Email-Benachrichtigung zu aktivieren und habe deine Antwort daher leider erst jetzt gelesen. Zwischenzeitlich habe ich - hoffentlich auch erfolgreich - eine eigene Function geschrieben, um in 2-dimensionalen Arrays doppelte Einträge zu löschen:
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
Für Optimierungsvorschläge meiner Funktion bin ich gerne offen.
Viele Grüße
Martin
Anzeige
Ergänzender Hinweis...
20.11.2010 19:44:11
Martin
Hallo,
also meine Function funktioniert bestens. Ich habe die doppelten Datensätze noch einmal manuell gelöscht und mein "manuelles" Ergebnis mit dem Ergebnis meiner Function verglichen. Doch eine entscheidende Vorbedingung für die Function hatte ich vergessen zu erwähnen: Das Quellarray muss zuvor sortiert werden (siehe http://www.online-excel.de/excel/singsel_vba.php?f=97), da nur die benachbarten Datensätze des Arrays verglichen werden.
Viele Grüße
Martin
AW: 2-dimensionales Array: Doppelte "Zeilen" löschen
21.11.2010 13:08:28
Martin
Hallo Ransi,
ich habe auch deinen Code getestet und auch dieser funktioniert einwandfrei. Der Vorteil von deinem Code besteht darin, dass dieser kürzer ist und keine Vorsortierung benötigt. Als einzigen Nachteil empfinde ich, dass die Daten sich am Ende in der Zwischenablage befinden. Gibt es eine Möglichkeit die Zwischenablage (ohne eine zwischenzeitliche Auslagerung der Daten in die Tabelle) wieder an das Array zu übergeben?
Obwohl mein Problem eigentlich gelöst ist, markiere ich diese Frage als offen. Ich denke, dass dein Lösungsweg besser ist und würde mich daher freuen, wenn wir deine Lösung noch optimieren.
Viele Grüße
Martin
Anzeige
Ebenfalls gelöst...
23.11.2010 21:20:54
Martin
Hallo an alle,
nach drei Tagen habe ich nun selbst eine Lösung gefunden:
Aufruf der Function mit:
Call TwinKiller(TestArray)
Die 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
Noch ein wichtiger Hinweis: Das Array beginnt nach Nutzung der Function bei (0, 0).
Viele Grüße
Martin
Anzeige
AW: Ebenfalls gelöst...
23.11.2010 22:28:36
Martin
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
Anzeige
Kein Fehler, aber sinnlos...
23.11.2010 22:49:09
Martin
Hallo,
selbstverständlich ist eine Addition mit Null völlig sinnlos, also kann die Zeile
ReDim arr(0 + RowDif To UBound(RowArr) + RowDif, 0 + ColDif To UBound(ColArr) + ColDif - 1)

durch folgende Zeile ersetzt werden:
ReDim arr(RowDif To UBound(RowArr) + RowDif, ColDif To UBound(ColArr) + ColDif - 1)

Gleich ist es 23 Uhr, da kann das schon mal passieren ;-)
Viele Grüße
Martin
Noch eine Sinnlosigkeit...
24.11.2010 09:38:24
Martin
Hallo,
langsam wird es peinlich, aber da Split quasi das Gegenteil von Join ist, macht sebstverständlich auch folgende Zeile nicht viel Sinn:
RowArr = Split((Join(myDic.keys, vbCrLf)), vbCrLf)

... und sollte durch ...
RowArr = myDic.keys

ersetzt werden. War zwar kein Fehler, aber gebracht hat es natürlich auch nichts. So, jetzt _ nochmal das (hoffentlich) endgültige Ergebnis:

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
Viele Grüße
Martin
Anzeige
Mehr Infos zu CreateObject("Scripting.Dictionary")
25.11.2010 19:51:08
Martin
Hallo,
da ich auf das Dictionary erst durch ransi in diesem Thread aufmerksam geworden bin und sehr interessant finde, möchte ich noch einen informativen Link dazu nennen: www.w3schools.com/asp/asp_ref_dictionary.asp
Bezieht sich zwar auf ASP (Active Server Pages), aber ASP und VBA sind nahezu identisch. Ich habe zwei Array-Lösungen bei mir inzwischen durch das Dictionary ersetzt, weil durch die Möglichkeit der Exist- und Item-Methoden die in Array notwendigen Schleifen erspart bleiben und auch die wegfallende Dimensionierung Vorteile bringt. Ich bin erstaunt, dass das Dictionary mir bislang entgangen ist.
Viele Grüße
Martin
Anzeige

324 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige