Finding all matches in column B with datalist in column A

[Pops Jackson]

I have data from two sources being pasted into columns A, B and C of a new
spreadsheet. Column A contains the account number, B the customer name and C
a description of the transaction, including the customer name. I have a
routine which finds the first occurence and pasted the account number into
column D but I need it to continue and do so for all occurences. I am using
the following which runs perfectly for one project but needs modifying for
the curent one.

Sub abc()
Windows("FXDH.xls").Activate
Sheets("FXDH").Activate
Dim rngA As Range, rngB As Range
Dim rng As Range, cell As Range
Dim res As Variant
With Worksheets("Sheet1")

Range("D").Select
Selection.Copy
Sheets("Sheet1").Activate
Range("B1").Select
ActiveCell.PasteSpecial
Application.CutCopyMode = False
Workbooks.Open ("T:\Fxbckoff\FXVolumeRpts\Customers.xls")
Sheets("qryCustomers").Activate
Range("A:A").Select
Selection.Copy
Windows("FXDH.xls").Activate
Sheets("Sheet1").Activate
Range("A1").Select
ActiveCell.PasteSpecial
Application.CutCopyMode = False
Stop
Set rngA = .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
Set rngB = .Range(.Cells(2, 2), .Cells(2, 2).End(xlDown))
End With

For Each cell In rngA
res = Application.Match("*" & cell.Value & "*", rngB, 0)
If Not IsError(res) Then
Set rng = rngB(res)
rng.Font.Color = RGB(255, 0, 0)
rng.Font.Bold = True
rng.Offset(0, 1) = cell.Offset(0, 0).Value
End If

Next

End Sub

How can I modify this to find all occurences?

Thanks,

Jim

 

[Tom Ogilvy]

add the dim statement

Dim sAddr as String


Replace your search loop with this:

For Each cell In rngA
rng = rngb.Find(What:=cell.Value, _
After:=rngb(rngb.count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng is nothing Then
sAddr = rng.Address
do
rng.Font.Color = RGB(255, 0, 0)
rng.Font.Bold = True
rng.Offset(0, 1) = cell.Offset(0, 0).Value
set rng= rngB.FindNext(rng)
Loop while rng.Address <> sAddr
End If
Next

 

[Pops Jackson]

I made the changes but am getting "Object variable or With block variable not
set." error message at the line after "For each cell in rngA". I am
including the code below after the changes.

Sub abc()
Windows("FXDH.xls").Activate
Sheets("Data").Activate

Dim sAddr As String
Dim rngA As Range, rngB As Range
Dim rng As Range, cell As Range
Dim res As Variant
With Worksheets("Sheet1")

ActiveSheet.Range("D").Select
Selection.Copy
Sheets("Sheet1").Activate
ActiveSheet.Range("B1").Select
ActiveCell.PasteSpecial
Application.CutCopyMode = False
Workbooks.Open ("T:\Fxbckoff\FXVolumeRpts\Customers.xls")
Sheets("qryCustomers").Activate
ActiveSheet.Range("A:A").Select
Selection.Copy
Windows("FXDH.xls").Activate
Sheets("Sheet1").Activate
ActiveSheet.Range("A1").Select
ActiveCell.PasteSpecial
Application.CutCopyMode = False

Set rngA = .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
Set rngB = .Range(.Cells(2, 2), .Cells(2, 2).End(xlDown))
End With

For Each cell In rngA
rng = rngB.Find(What:=cell.Value, _
After:=rngB(rngB.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
sAddr = rng.Address
Do
rng.Font.Color = RGB(255, 0, 0)
rng.Font.Bold = True
rng.Offset(0, 1) = cell.Offset(0, 0).Value
Set rng = rngB.FindNext(rng)
Loop While rng.Address < sAddr
End If
Next

End Sub

Thanks

 

[Pops Jackson]

I have tried every way to add, modify etc to make this work but to no avail.
If anyone has an idea, I would truly appreciate hearing from you.

Thanks in advance,