Das hier als Modul anlegen.
Die gleichen Namen werden farblich formatiert.
Zwar nicht genau das was du willst, aber mit zwei weiteren Klicks hast du es.
Option Compare Text
Option Explicit
Sub Compare_Columns_v01()
'Base: --
'This Macro compares 2 Columns and highlights common values
'Modifications:
'------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' VARIABLES:
Dim kWord As String, msg As String, ColAd1 As String, ColAd2 As String, Col1 As String, Col2 As String
Dim nCol As Long, lRow As Long, lRow1 As Long, lRow2 As Long, lCol As Long, startpos As Long, startpos1 As Long, KWordCol As Long, ColNo1 As Long, ColNo2 As Long
Dim a As Long, i As Long, j As Long, iRow As Long, jRow As Long
Dim rngcell As Range, sRange1 As Range, sRange2 As Range, sRange As Range, UsedRange As Range, rng1 As Range, rng2 As Range
' SCREEN UPDATING SWITCHED OFF:
With Application
.ScreenUpdating = False
.EnableEvents = False
' .Calculation = xlCalculationManual
End With
' INPUT OF COLUMN 1 AND 2:
Col1 = InputBox("Column 1 (for example A, BC...)")
Col2 = InputBox("Column 2 (for example A, BC...)")
' EXTRACT ADDRESS OF COLUMNS:
ColAd1 = ActiveSheet.Range(Col1 & "1").Address
ColAd2 = ActiveSheet.Range(Col2 & "1").Address
' EXTRACT COLUMN NUMBERS:
ColNo1 = Range(ColAd1).column
ColNo2 = Range(ColAd2).column
' CHECK IF COLUMNS 1 OR 2 ARE EMPTY:
Set rng1 = ActiveSheet.Columns(ColNo1)
a = Application.WorksheetFunction.CountA(rng1)
If a = 0 Then
msg = MsgBox("Column '" & Col1 & "' is empty!", vbInformation)
Exit Sub
End If
'1 MsgBox (Err.Number)
Set rng2 = ActiveSheet.Columns(ColNo2)
a = Application.WorksheetFunction.CountA(rng2)
'MsgBox (Err.Number)
If a = 0 Then
msg = MsgBox("Column '" & Col2 & "' is empty!", vbInformation)
Exit Sub
End If
' DETREMINE LAST USED ROW AND COLUMN:
lRow1 = ActiveSheet.Cells(Rows.Count, ColNo1).End(xlUp).row
lRow2 = ActiveSheet.Cells(Rows.Count, ColNo2).End(xlUp).row
lCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).column
msg = MsgBox("Length of column 1: " & lRow1)
msg = MsgBox("Length of column 2: " & lRow2)
' REFORMAT CELLS CONTAINING 0 TO '0:
iRow = 1
jRow = 1
For i = 1 To lRow1
If Cells(iRow, ColNo1).value = "0" Then Cells(iRow, ColNo1).value = "'0"
iRow = iRow + 1
Next i
For j = 1 To lRow2
If Cells(jRow, ColNo2).value = "0" Then Cells(jRow, ColNo2).value = "'0"
jRow = jRow + 1
Next j
' COMPARE AND HIGHLIGHT COLUMNS 1 AND 2:
iRow = 1
jRow = 1
For j = 1 To lRow2
For i = 1 To lRow1
If Cells(iRow, ColNo1).value = Cells(jRow, ColNo2).value Then
Cells(iRow, ColNo1).Font.ColorIndex = 5
Cells(iRow, ColNo1).Font.FontStyle = "Bold Italic"
Cells(jRow, ColNo2).Font.ColorIndex = 5
Cells(jRow, ColNo2).Font.FontStyle = "Bold Italic"
End If
iRow = iRow + 1
Next i
jRow = jRow + 1
iRow = 1
Next j
' SCREEN UPDATING SWITCHED OFF:
With Application
.ScreenUpdating = True
.EnableEvents = True
' .Calculation = xlCalculationManual
End With
End Sub
(obwohl ich VBA recht gut beherrsche).
