Thread: Matching >1 value in a loop?

Hi guys,

If the following macro matchs two ID numbers from column B in column C it shoud highlight them green.

Column C may has multiple entries of column B, however the macro i have written appears to only match the first ID number found in column C from B.

I think this may have something to do with my loop, can anyone suggest a solution?

Sub colour_filter()

Dim myrange As Range
Dim Rng As Range
Dim rng1 As Range
Dim a As Integer
   
    Set Rng = ActiveSheet.Range("B2", Range("B" & Rows.Count).End(xlUp))
    Set rng1 = ActiveSheet.Range("C2", Range("C" & Rows.Count).End(xlUp))
    a = 0
   
    For Each myrange In Rng
      If IsNumeric(Application.Match(myrange.Value, rng1, 0)) Then
         rng1(Application.Match(myrange.Value, rng1, 0), 1).Range _
         ("A1", Cells(1, Columns.Count).End(xlToLeft)).Interior.color = vbGreen
         a = a + 1
      End If
    Next myrange
   
MsgBox "Number of matches: " & a

End Sub

Many thanks,

D

Hi dems
cant you just use conditional formating?
something like
Forumlais=countif($B$1:$C$100),A1)>1

The suggestion to use CF was made in this original post - with no response from the OP.
VBA search and highlight macro
Thread is now locked.

A sample workbook has been requested twice - no response. It would save us all some time.

oh try something like...

Sub ptest()
    Dim ws1 As Worksheet
    Dim FoundOne As Range, LookInR As Range, LookForR As Range, c As Range
    Dim fAddress
    Application.ScreenUpdating = False
    Set ws1 = Sheets("Sheet1")
     Set LookInR = ws1.Range(ws1.Range("c1"), ws2.Range("c" & Rows.Count).End(xlUp))
    Set LookForR = ws1.Range(ws1.Range("b1"), ws2.Range("b" & Rows.Count).End(xlUp))
    For Each c In LookForR
        With LookInR
            Set FoundOne = .Find(What:=c, lookat:=xlPart)
            If Not FoundOne Is Nothing Then
                fAddress = FoundOne.Address
                Do
                 c.Resize(1, 1).Interior.Color = vbGreen
                 FoundOne.Resize(1, 1).Interior.Color = vbGreen
                    Set FoundOne = .FindNext(After:=FoundOne)
                Loop While FoundOne.Address <> fAddress
            End If
        End With
    Next c
    Set ws1 = Nothing
    Set LookInR = Nothing: Set LookForR = Nothing
    Application.ScreenUpdating = True
End Sub

something like

Sub ptestp()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim FoundOne As Range, LookInR As Range, LookForR As Range, c As Range
    Dim nr3    As Long, fAddress
    Application.ScreenUpdating = False
    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
    Set ws3 = Sheets("Sheet3")
    Set LookInR = Range(ws1.Range("A1"), ws1.Range("B" & Rows.Count).End
    Set LookForR = Range(ws2.Range("A1"), ws2.Range("C" & Rows.Count).End(xlUp))
    nr3 = ws3.Range("A" & Rows.Count).End(xlUp).Row + 1
    For Each c In LookForR
        With LookInR
            Set FoundOne = .Find(What:=c, lookat:=xlPart)
 
            If Not FoundOne Is Nothing Then
                fAddress = FoundOne.Address
                Do
                    'FoundOne.EntireRow.Copy Destination:=ws3.Cells(nr3, 1)
                    FoundOne.Offset(0, 1).Copy Destination:=ws3.Cells(nr3, 4)    '.Value = DXFDict.Item(Key)
                    nr3 = nr3 + 1
                    Set FoundOne = .FindNext(After:=FoundOne)
                Loop While FoundOne.Address <> fAddress
            End If
        End With
    Next c
    Set ws1 = Nothing
    Set ws2 = Nothing
    Set ws3 = Nothing
    Set LookInR = Nothing: Set LookForR = Nothing
    Application.ScreenUpdating = True

What I see is this

    Set LookInR = Range(ws1.Range("A1"), ws1.Range("B" & Rows.Count).End

Some code has disapeared (End(xlup)) ?? as well as like End Sub ??

... and fAddress is a String

Pikes code works but it seems a bit strange to me that
LookInR is in Sheet1 Column 1 & 2
LookForR is in Sheet2 Columns 1,2,3
FoundOne is set (pointer) to the cell in Sheet1 (LookInR)
and then
FoundOne.Offset(0, 1).Copy Destination:=ws3.Cells(nr3, 4)

If LookinR was a single column and you need to look up the ID in that columns and copy the data to the right of the found ID to Sheet3, that would make sence.

Now
When the ID is found in Column 1 the data on the right is also an ID ??

Summarizing:
Why should the LookForR and LookIn R be multidimensional. I would say these are all one dimension like in Pike's first approach?

Finally managed to get my head around the problem using a nested loop. Applied code for future reference below:

Sub FilterV2()

Dim Rng, rng1 As Range
Dim a As Double
Dim intcounter, intcounter1 As Double
Dim intNumberOfRecords, intNumberOfRecords1 As Double

Set Rng = ActiveSheet.Range("B2", Range("B" & Rows.Count).End(xlUp))
Set rng1 = ActiveSheet.Range("C2", Range("C" & Rows.Count).End(xlUp))


intNumberOfRecords = Rng.Rows.Count - 1
intNumberOfRecords1 = rng1.Rows.Count - 1
a = 0   

    For intcounter = 0 To intNumberOfRecords
      For intcounter1 = 0 To intNumberOfRecords1
            If (Rng(intcounter) = rng1(intcounter1)) Then
                Rows(intcounter1 + 1).Select
                Selection.Copy
                Worksheets("Filter").Select
                ActiveSheet.Range("C65536").End(xlUp).Offset(1, 0).Select
                ActiveSheet.Paste Link:=True
                Worksheets("Sheet 1").Select
                a = a + 1
            End If
      Next
    Next
     
MsgBox "Number of matches: " & a

End Sub

A little brutish is selecting rows, since I couldn't get this to work dynamically, ie the following wouldnt work.

Range(intcounter + 1, Cells(1, Columns.Count).End(xlToLeft)).Select

Also less automated as you have to execute the code between different sheets and update the macro's return reference.

Otherwise, thank's everyone for taking the time to help.