Gleiche Zeilen zusammenfassen und zählen

[kosmoritz]

Vielen Dank, Atilla, ich benutze tatsächlich Edge und das war das Problem!
Entschuldige für die lange Reaktionszeit aber Urlaub muss auch mal sein.
Jetzt läuft der Code auf jeden Fall reibungslos durch.

Was müsste ich machen wenn ich den Vergleich der Spalten erweitern will? Habe in einem anderen Beispiel 7 Spalten die ich auf Gleichheit überprüfen  will (A bis G). Habe schon versucht den Einlesen Abschhnitt, sowie untenstehenden Codeschnipsel anzupassen, jedoch ohne Erfolg.

Code:

varEin = Range("A2:G" & lngZeile)

Mir ist glaube ich die genaue Funktionsweise dieses Codeteils nicht ganz klar

Code:

'Einlesen
 For lngZeile = 1 To UBound(varEin, 1)
     varKey = varEin(lngZeile, 1) & " " & varEin(lngZeile, 2) & " " & varEin(lngZeile, 3)
     strDict(varKey) = strDict(varKey) & ", " & varEin(lngZeile, 4)
 Next lngZeile

 'zur Ausgabe vorbereiten
 ReDim varAus(1 To strDict.Count, 1 To 5)
 lngZeile = 1
 For Each varKey In strDict.keys
     varAusgabe = Split(varKey)
     varAus(lngZeile, 1) = varAusgabe(0)
     varAus(lngZeile, 2) = varAusgabe(1)
     varAus(lngZeile, 3) = varAusgabe(2)
     varAus(lngZeile, 4) = Mid(strDict(varKey), 3)
     varAus(lngZeile, 5) = UBound(Split(strDict(varKey), ","))
     lngZeile = lngZeile + 1
 Next varKey

VG

Moritz

[kosmoritz]

Hier noch ein anderer Lösungsweg den ich gefunden habe. Hier werden 7 Spalten auf Gleichheit überprüft.

Code:

Sub yuhu()

    ActiveSheet.Select
    totalrows = ActiveSheet.UsedRange.Rows.Count
    Count = 1
    For Row = totalrows To 2 Step -1
        If Cells(Row, 1).Value = Cells(Row - 1, 1).Value And Cells(Row, 2).Value = Cells(Row - 1, 2).Value And Cells(Row, 3).Value = Cells(Row - 1, 3).Value And Cells(Row, 4).Value = Cells(Row - 1, 4).Value And Cells(Row, 5).Value = Cells(Row - 1, 5).Value And Cells(Row, 6).Value = Cells(Row - 1, 6).Value And Cells(Row, 7).Value = Cells(Row - 1, 7).Value Then
            Rows(Row).Delete
            Count = Count + 1
        Else
            Cells(Row, 8).Value = Count
            Count = 1
        End If
    Next Row
    Cells(1, 8).Value = Count

End Sub

[atilla]

Hallo,

Du wolltest aber ursprünglich noch eine kommagetrennte Zusammenfassung eines Schlüssels aus der letzten Spalte.

Angenommen Spalten A bis G sollen augf Gleichheit geprüft werden und in Spalte H befindet sich der zusammenzufassende Schlüssel, dann macht unten der Code das und schreibt die Ergebnisse ab Spalte J:

Code:

Sub Machs()

Dim lngZeile As Long
Dim varKey As Variant
Dim varEin As Variant
Dim varAus As Variant
Dim varAusgabe As Variant

Dim strDict As Object

With Sheets("Tabelle1")
 lngZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
 Set strDict = CreateObject("Scripting.Dictionary")

 varEin = Range("A2:H" & lngZeile) 'eingelesener Bereich

 'Einlesen
 For lngZeile = 1 To UBound(varEin, 1)
     varKey = varEin(lngZeile, 1) & " " & varEin(lngZeile, 2) & " " & varEin(lngZeile, 3) & " " & varEin(lngZeile, 4) & " " & varEin(lngZeile, 5) & " " & varEin(lngZeile, 6) & " " & varEin(lngZeile, 7)
     strDict(varKey) = strDict(varKey) & ", " & varEin(lngZeile, 8)
 Next lngZeile

 'zur Ausgabe vorbereiten
 ReDim varAus(1 To strDict.Count, 1 To 9)
 lngZeile = 1
 For Each varKey In strDict.keys
    varAusgabe = Split(varKey)
    varAus(lngZeile, 1) = varAusgabe(0)
    varAus(lngZeile, 2) = varAusgabe(1)
    varAus(lngZeile, 3) = varAusgabe(2)
    varAus(lngZeile, 4) = varAusgabe(3)
    varAus(lngZeile, 5) = varAusgabe(4)
    varAus(lngZeile, 6) = varAusgabe(5)
    varAus(lngZeile, 7) = varAusgabe(6)
    varAus(lngZeile, 8) = Mid(strDict(varKey), 7)
    varAus(lngZeile, 9) = UBound(Split(strDict(varKey), ","))
    lngZeile = lngZeile + 1
 Next varKey

 'Ausgeben
 .Range("j1").CurrentRegion.ClearContents 'Bereich leeren
 .Range("j1").Resize(strDict.Count, 9) = varAus
End With

Set strDict = Nothing
End Sub