VBA-Programmierung in Microsoft Excel

Doppelte Datensätze farblich markieren und auflisten

StandardModule: basMain

Sub Vergleich()
   Dim iRowA As Integer, iRowB As Integer
   Dim iCol As Integer, iColor As Integer
   Dim iRowC As Integer
   Dim bln As Boolean, blnColor As Boolean
   iRowA = 2
   iColor = 2
   Do Until IsEmpty(Cells(iRowA, 1))
      iRowB = iRowA + 1
      Do Until IsEmpty(Cells(iRowB, 1))
         For iCol = 1 To 3
            If Cells(iRowA, iCol) <> Cells(iRowB, iCol) Then
               bln = True
               Exit For
            End If
         Next iCol
         If bln = False Then
            If blnColor = False Then
               iColor = iColor + 1
            End If
            If Cells(iRowB, 1).Interior.ColorIndex = _
               xlColorIndexNone Then
               If Cells(iRowA, 1).Interior.ColorIndex = _
                  xlColorIndexNone Then
                  With Worksheets(3)
                     iRowC = .Cells(Rows.Count, 1).End(xlUp).Row + 1
                     .Range(.Cells(iRowC, 1), .Cells(iRowC, 3)).Value = _
                        Range(Cells(iRowB, 1), Cells(iRowB, 3)).Value
                  End With
               End If
               Range(Cells(iRowA, 1), Cells(iRowA, 3)). _
                  Interior.ColorIndex = iColor
               Range(Cells(iRowB, 1), Cells(iRowB, 3)). _
                  Interior.ColorIndex = iColor
               blnColor = True
            End If
         End If
         iRowB = iRowB + 1
         bln = False
      Loop
      blnColor = False
      iRowA = iRowA + 1
   Loop
End Sub

    

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