Hier ein Makro, um doppelte Datensätze innerhalb der aktuellen Markierung auf einem separaten Tabellenblatt, welches erstellt wird, zu listen.

 

 

 

 

Es wird im Codeverlauf geprüft, ob das erste ( Sheet links ) Tabellenblatt der Datei "DOPPELTE" heißt. Wenn vorhanden, werden die Daten der Spalte A gelöscht, damit keine Altdaten einer vorherigen Abfrage übrigbleiben. Existiert das Tabellenblatt nicht, wird es angelegt.

 

 

 

 

Der Code für ein allgemeines Modul.

 

Public Sub Doppelte_Eintraege2()

'#####################################

'Code für ein allgemeines Modul

'Code sucht innerhalb der Markierung nach doppelten Datensätzen

'Doppelte werden in neuem Blatt - DOPPELTE - gelistet

'Autor: Jürgen Hennekes

'#####################################

Dim wks As Worksheet

Dim objDic As Object

Dim rngCell As Range

Dim bln As Boolean

Dim arr() As Variant

Dim z As Long

 

Set objDic = CreateObject("Scripting.Dictionary")

z = 1

 

For Each rngCell In Selection

  If rngCell.Value <> "" Then

    If objDic.exists(rngCell.Value) = False Then

      objDic(rngCell.Value) = 0

        Else

      ReDim Preserve arr(1 To z)

      arr(z) = rngCell.Value

      z = z + 1

   End If

  End If

Next

 

If z > 1 Then

  If Worksheets(1).Name <> "DOPPELTE" Then

    Set wks = Worksheets.Add

    wks.Move before:=Worksheets(1)

    wks.Name = "DOPPELTE"

    wks.Range("A1").Value = "DOPPELTE"

    wks.Range("A1").Font.Bold = True

    wks.Range("A2").Resize(UBound(arr)) = WorksheetFunction.Transpose(arr)

      Else

    With Worksheets(1)

      .Range("A:A").ClearContents

      .Range("A1").Value = "DOPPELTE"

      .Range("A1").Font.Bold = True

      .Range("A2").Resize(UBound(arr)) = WorksheetFunction.Transpose(arr)

      .Activate

    End With

  End If

  MsgBox "Die doppelten Datensätze wurden in Sheet [ DOPPELTE ] gelistet", 64

    Else

  MsgBox "Keine doppelten Datensätze innerhalb der Markierung vorhanden.", 48

End If

   

End Sub