Thema: Datensätze, die öfter als 3 mal vorkommen, kopieren

StandardModule: Modul1

Sub MatchCopy()
   Dim rng As Range, rCell As Range
   Dim iRow As Integer
   Set rng = Range("A1").CurrentRegion
   Workbooks.Add 1
   For Each rCell In rng.Columns(1).Cells
      If WorksheetFunction.CountIf(rng.Columns(1), rCell.Value) > 3 Then
         iRow = iRow + 1
         rng.Rows(rCell.Row).Copy Cells(iRow, 1)
      End If
   Next rCell
   If IsEmpty(Range("A1")) Then
      ActiveWorkbook.Close savechanges:=False
      Beep
      MsgBox "Keine Datensätze gefunden!"
   Else
      Columns.AutoFit
   End If
End Sub

Beiträge aus dem Excel-Forum zu den Themen Allgemein und Vergleich