Option Explicit
Sub Test()
Dim rngData As Excel.Range
Dim rngCell As Excel.Range
Dim strFormula As String
Set rngData = Range("A7").CurrentRegion
If rngData.Rows.Count = 1 Then Exit Sub '< falls keine Daten vorhanden
Set rngData = rngData.Resize(rngData.Rows.Count - 1).Offset(1)
With rngData.Columns(rngData.Columns.Count).Offset(0, 1)
'Formel zum Erzeugen des Dupletten-Schlüssels erstellen
strFormula = "=CONCAT("
For Each rngCell In rngData.Rows(1).Cells
strFormula = strFormula & rngCell.Address(False, False, xlR1C1, RelativeTo:=.Cells(1)) & ",""|"","
Next
Mid$(strFormula, Len(strFormula)) = ")"
'#Hilfsspalten
' - Dupletten-Schlüssel
.Offset(0, 0).FormulaR1C1 = strFormula
' - Anzahl jeder Duplette
.Offset(0, 1).FormulaR1C1 = "=COUNTIF(" & .Address(True, True, xlR1C1) & ",RC[-1])"
' - Id für RemoveDuplicates
.Offset(0, 2).FormulaR1C1 = "=MATCH(RC[-2]," & .Address(True, True, xlR1C1) & ",0)"
'Werte von Anzahl und Id nach links übernehmen
.Offset(0, -1).Resize(, 2).Value = .Offset(0, 1).Resize(, 2).Value
.Offset(0, 1).Resize(, 2).ClearContents
With rngData.Resize(, rngData.Columns.Count + 1)
'Duplikate anhand Id (=letzte Spalte) entfernen
Call .RemoveDuplicates(.Columns.Count)
End With
'Id entfernen
.ClearContents
End With
End Sub
|