Need to return multiple values based upon multiple criteria

[klop]

I'm not sure if Excel or Access is the best tool.

I am seeking to search for roughly 1,000 unique search strings amongst 100,000 customers and identify all string matches. The customer data set consists of customer ID (column A) and customer name (column B). I would like to return all customer ID's and customer names that match any of the 1,000 search strings in another tab or in a dedicated query (if performed in access). For clarification if necessary, I would like the match to be a contains match, not necessarily an exact match.

I assume this could be done in VBA by looking up every line? Does anyone have similar code that could be applied?

Thanks

 

[mirabeau]

Hi,

You can try this on some test data to see if it's the sort of thing you want.

Basic data, i.e customer names and ID's on sheet1, cols 1 and 2, and the 1000 search strings down Column 1 on sheet2.

Try it on test or sample data first.

Sub matchesandstuff()
Dim a As Range, b, c(), f, x, y
b = Sheets("sheet2").Range("A1").CurrentRegion
Sheets("sheet1").Activate
n = Range("A:B").Find("*", LookIn:=xlValues, searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row
Set a = Range("A1").Resize(n, 2)
ReDim c(1 To n, 1 To 1)
For Each e In b
    Set f = a.Find(e, lookat:=xlPart, MatchCase:=True)
    If Not f Is Nothing Then
        x = f.Row
        c(x, 1) = 1
        Do
            Set f = a.FindNext(f)
            c(f.Row, 1) = 1
        Loop While f.Row <> x
    End If
Next e
Range("C:C").Insert
Range("C1").Resize(n) = c
a.Resize(, 3).Sort [c1], 1
y = Range("C1").End(4).Row
a(y + 1, 1).Resize(n - y, 2).Clear
Range("C:C").Delete
End Sub

 

[klop]

Thanks - it appears to work. However, the values were returned on sheet 1 and replaced the original customer name and id. Is it possible to place the search results in another tab?

Thanks so much - this is a tremendous time saver for me!

 

[mirabeau]

How about this modification.

Should leave Sheet1 unchanged and lists results on Sheet3.

Sub matchesandstuff2()
Dim a As Range, b, c(), f, x, y
Application.ScreenUpdating = False
b = Sheets("sheet2").Range("A1").CurrentRegion
Sheets("sheet1").Activate
n = Range("A:B").Find("*", LookIn:=xlValues, searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row
ReDim c(1 To n, 1 To 1)
Sheets("sheet3").Activate
Sheets("sheet1").Range("A1").Resize(n, 2).Copy [a1]
Set a = Range("A1").Resize(n, 2)
For Each e In b
    Set f = a.Find(e, lookat:=xlPart, MatchCase:=True)
    If Not f Is Nothing Then
        x = f.Row
        c(x, 1) = 1
        Do
            Set f = a.FindNext(f)
            c(f.Row, 1) = 1
        Loop While f.Row <> x
    End If
Next e
Range("C:C").Insert
Range("C1").Resize(n) = c
a.Resize(, 3).Sort [c1], 1
y = Range("C1").End(4).Row
a(y + 1, 1).Resize(n - y, 2).Clear
Range("C:C").Delete
Application.ScreenUpdating = True
End Sub