Aha, Leo heeft al hetzelfde geantwoord! ('k heb het dan niet over de allerlaatste post)
Hier een bijgewerkte versie van mijn code: 't is hier druk, dus testen gebeurde in de vlucht.
Option Explicit
Sub list_matches()
'Erik Van Geit
'070708
'compare columns A & B and list matches in column C
'Row 1 = headers
'EXAMPLE
' A B C
'1 LIST 1 LIST 2 MATCHES
'2 Item 4 Item 4 Item 4
'3 Item 3 Item 5 Item 1
'4 Item 1 Item 2 Item 9
'5 Item 6 Item 1 Item 8
'6 Item 7 Item 9
'7 Item 8 Item 8
'8 Item 10
'9 Item 9
Dim LR As Long
Dim AFM As Boolean
Application.ScreenUpdating = False
AFM = ActiveSheet.AutoFilterMode
ActiveSheet.AutoFilterMode = False
If Application.WorksheetFunction.CountA(Range("C1:D" & Rows.Count)) Then
If MsgBox("The data in columns C & D will be erased. Continue?", 36, "WARNING") = vbNo Then Exit Sub
End If
With Range("A1:B" & Rows.Count)
LR = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False).Row
End With
With Range("C2:C" & LR)
.Formula = "=IF(COUNTIF(R2C1:R" & LR & "C1,RC[-1]),1,0)"
.Value = .Value
If Application.Sum(.Offset(0)) = 0 Then
MsgBox "No matches found", 48, "REPORT"
Else
.Offset(-1, 0).AutoFilter Field:=1, Criteria1:="1"
.Offset(0, -1).Copy
.Offset(0, 1).Resize(1, 1).PasteSpecial xlPasteValues
End If
.EntireColumn.delete
End With
Range("C1") = "MATCHES"
Application.ScreenUpdating = True
End Sub
Hierbij een voorbeeld van code die eerst de hele zaak naar het geheugen schrijft, daar alle bewerkingen doet en dan alles in 1 blok terug naar het werkblad zet. Behalve "trim" heb ik ook "clean" toegevoegd (zie helpfiles). Zo ben je toch nogal zeker dat alle overbodige dingen weggeveegd zijn vooraleer je gaat vergelijken.
Sub test()
'Erik Van Geit
'code will BUG if some cells are containing errors like #NAME, #ISNA, etcetera, enable 'On Error'lines
Dim rng As Range
Dim arr As Variant
Dim i As Long
Dim j As Long
Dim RC As Long
Dim CC As Long
Set rng = Selection
arr = rng
RC = rng.Rows.Count
CC = rng.Columns.Count
Application.StatusBar = "handling first column of data"
'On Error Resume Next
For j = 1 To CC
For i = 1 To RC
'do whatever with the data
arr(i, j) = Application.Clean(Trim(arr(i, j)))
Next i
Application.StatusBar = Format(j / CC, "###%")
Next j
'On Error GoTo 0
Application.StatusBar = False
rng = arr
Erase arr
End Sub