ExcelBanter - Finding Matching Data on Another Sheet

On May 15, 6:22 pm, merjet wrote:
http://groups.google.com/group/micro...rogramming/bro...

Hth,
Merjet

Merjet:

Thanks again, it took me a while to understand exactly what you gave
me (probably because I'm a bit thick :-) ), but here's what I came up
with. It works like a charm!

Private Sub WashLeads()
'Note: EndRow is calculated by counting the number of cells with a
Company Name in it
' and is initialized in the main procedure. This takes into
account any leads
' that may not have a DUNS number in the data.
Dim c1 As Range 'DUNS Number as listed on Working Copy
Dim c2 As Range 'DUNS Number as listed on Wash List
Dim c3 As Range 'Washed Leads cell where washed lead will be pasted
Dim rng1 As Range 'List of DUNS Numbers from Working Copy
Dim rng2 As Range 'List of DUNS Numbers from Wash List
Dim iRow As Long 'Row counter for looping purposes
Dim MyRow As Range 'Row on Working Copy that will be moved to the
Washed Leads sheet
Dim StartRow As Long 'Row where deletion from Working Copy will
start
Dim CalcMode As Long
Dim ViewMode As Long

'Initialize the ranges to be compared
With Worksheets("Working Copy")
Set rng1 = .Range("M2", .Cells(EndRow, 13))
End With
With Worksheets("Wash List")
Set rng2 = .Range("B2", .Cells(EndRow, 2))
End With
'Create a new worksheet to place any leads that were washed
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Washed Leads"
Set c3 = Worksheets("Working Copy").Range("A1")
'Set the header row on the new worksheet
With Worksheets("Working Copy")
Set MyRow = c3.EntireRow
MyRow.Copy Destination:=Worksheets("Washed Leads").Range("A1")
End With
With Worksheets("Washed Leads").Range("AC1")
.Value = "Client ID Lead Duplicates"
.Font.Bold = True
End With
'Loop through the cells in each range and compare the DUNS number
values
'If match, flag matches by changing font to red on the Working Copy
data
Set c3 = ActiveSheet.Range("A2")
For Each c1 In rng1
For Each c2 In rng2
If c1.Value = c2.Value Then
iRow = iRow + 1
Set MyRow = c1.EntireRow
Set c3 = ActiveSheet.Range("A2")
c3.Offset(iRow).Activate
MyRow.Copy Destination:=c3(iRow)
MyRow.Font.Color = RGB(255, 0, 0)
c2.Offset(0, -1).Resize(1, 1).Copy Destination:=c3.Cells(iRow,
29)
End If
Next c2
Next c1
'Delete any borders and make the columns wide enough to display all
data
Cells.Select
Cells.EntireColumn.AutoFit
Cells.Borders.LineStyle = xlLineStyleNone
ActiveSheet.Range("A1").Select
'Loop through the records on the Working Copy worksheet and delete
'any rows with red font color.
Worksheets("Working Copy").Activate
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
With ActiveSheet
.DisplayPageBreaks = False
StartRow = 2
For iRow = EndRow To StartRow Step -1
If IsError(.Cells(iRow, "A").Value) Then
'Do nothing, This avoids a error if there is a error in
the cell
ElseIf .Cells(iRow, "A").Font.Color = RGB(255, 0, 0)
Then .Rows(iRow).Delete
'This will delete each row with red font color.
End If
Next
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub

Jana