gleiche Zeilen zusammenfassen und Anzahl

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
Nachstehender Code erzeugt Unikate und zählt diese, wie oft sie in Tabelle1 vorkommen. Ergebnis wird in Tabelle2 ausgegeben. Gesucht wird nach Übereinstimmung in 2 Spalten.
Gehr sicher etwas einfacher aber es funktioniert.


Option Explicit
Sub Gleiche_zusammenfssen()
Dim arrDaten As Variant, arrTmp As Variant
Dim n As Long, x As Long, z As Long
' alle Daten in das Array 'arrDaten' Beginn: arrDaten(1 to count(arrDaten), 1 to 11)
With ThisWorkbook.Worksheets("Tabelle1")
arrDaten = .Range("A3:K" & .Cells(.Rows.Count, 3).End(xlUp).Row)
End With
' Nach welche Kriterien soll verglichen werden
' in diesem Fall: Marke und Artikel werden in einen Stzring zusammengefasst
ReDim arrTmp(1 To UBound(arrDaten), 1 To 1)
For n = 1 To UBound(arrDaten)
arrTmp(n, 1) = arrDaten(n, 4) & "|" & arrDaten(n, 5)
Next n
Dim dicWare As Object
Set dicWare = CreateObject("Scripting.Dictionary")
' Keys enthält die verschiedenen Unkate und der Item wie oft sie vorkommen
For x = 1 To UBound(arrTmp)
dicWare(arrTmp(x, 1)) = dicWare(arrTmp(x, 1)) + 1
Next
Dim arrErg As Variant
ReDim arrErg(1 To dicWare.Count, 1 To 11)
Dim dicItems As Variant: dicItems = dicWare.Items
Dim dicKeys As Variant: dicKeys = dicWare.keys
Dim arrSplit As Variant
For n = 0 To dicWare.Count - 1
arrSplit = Split(dicKeys(n), "|")
For x = 1 To UBound(arrDaten)
If arrDaten(x, 4) = arrSplit(0) And arrDaten(x, 5) = arrSplit(1) Then
' Marke und Artikel stimmen überein ---> Ergebnis in arrErg
For z = 1 To 10
arrErg(n + 1, z) = arrDaten(x, z)
Next z
arrErg(n + 1, 11) = dicItems(n) '---> wie oft kommen sie vor
Exit For
End If
Next x
Next n
' Ausgabe beginnend bei Zelle A2 im Tabellenblat 'Tabelle2'
With Sheets("Tabelle2")
.Range("A3").Resize(UBound(arrErg, 1) - LBound(arrErg, 1) + 1, UBound(arrErg, 2) - LBound(arrErg, 2) + 1) = arrErg
End With
End Sub

mfg GraFri

Option Explicit Sub Gleiche_zusammenfassen_2() Dim arrDaten As Variant, arrTmp As Variant Dim n As Long, x As Long ' alle Daten in das Array 'arrDaten' Beginn: arrDaten(1 to count(arrDaten), 1 to 11) With ThisWorkbook.Worksheets("Tabelle1") arrDaten = .Range("A3:K" & .Cells(.Rows.Count, 3).End(xlUp).Row) End With ' Nach welche Kriterien soll verglichen werden ' in diesem Fall: Spalte A bis J werden verglichen ReDim arrTmp(1 To UBound(arrDaten), 1 To 1) For n = 1 To UBound(arrDaten) For x = 1 To 10 arrTmp(n, 1) = arrTmp(n, 1) & arrDaten(n, x) & "|" Next x Next n Dim dicWare As Object Set dicWare = CreateObject("Scripting.Dictionary") ' Keys enthält die verschiedenen Unkate und der Item wie oft sie vorkommen For x = 1 To UBound(arrTmp) dicWare(arrTmp(x, 1)) = dicWare(arrTmp(x, 1)) + 1 Next Dim arrErg As Variant ReDim arrErg(1 To dicWare.Count, 1 To 11) Dim dicItems As Variant: dicItems = dicWare.Items Dim dicKeys As Variant: dicKeys = dicWare.keys For n = 0 To dicWare.Count - 1 For x = 1 To 10 arrErg(n + 1, x) = Split(dicKeys(n), "|")(x - 1) Next x arrErg(n + 1, 11) = dicItems(n) '---> wie oft kommen sie vor Next n ' Ausgabe beginnend bei Zelle A2 im Tabellenblat 'Tabelle2' With Sheets("Tabelle2") .Range("A3").Resize(UBound(arrErg, 1) - LBound(arrErg, 1) + 1, UBound(arrErg, 2) - LBound(arrErg, 2) + 1) = arrErg End With End Sub

Beliebteste Forumthreads (12 Monate)

gleiche Zeilen zusammenfassen und Anzahl

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

gleiche Zeilen zusammenfassen und Anzahl

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread