AW: Doppelte auflisten spezial
K.Rola
Hallo,
ich hoffe, ich habe dich richtig verstanden. Der Code muss in ein Standardmodul:
Option Explicit
Sub Doppelte_spezial()
Dim ws1 As Worksheet, ws2 As Worksheet, z1 As Long, z2 As Long
Set ws1 = Sheets("Tabelle1")
Set ws2 = Sheets("Tabelle2")
For z1 = 1 To ws1.[A65536].End(-4162).Row
If Application.CountIf(ws1.[A:A], ws1.Cells(z1, 1)) > 1 Then
If Application.CountIf(ws2.[A:A], ws1.Cells(z1, 1)) = 0 Then
z2 = ws2.[A65536].End(-4162).Row + 1
ws2.Cells(z2, 1) = ws1.Cells(z1, 1)
ws2.Cells(z2, 2) = Application.CountIf(ws1.[A:A], ws1.Cells(z1, 1))
End If
End If
Next
With ws2
.[a1] = "Unikat"
.[b1] = "Anzahl"
.Rows(1).Font.Bold = True
.[a:b].Columns.AutoFit
End With
End Sub
Gruß K.Rola