Solved: Difficult... Macro to search multiple workbooks for a match?

[linkjg]

Hello! I am trying to figure out a macro to help me with this...

In Workbook A, column C has a list of ID numbers.

That ID number is located on some workbook located in the C:\Accounting folder

If a match is found, the information from column S and T on the workbook in C:\Accounting must be added to columns D and E next to the matching ID number on Workbook A.

Do you know of a macro that can help?

[XLGibbs]

Is the ID in Column C of the workbook to be found?

Are these ID relative data in multiple workbooks or just one?

Assuming that all the matching data is in ONE workbook, this will cycle through all excel files in C:Accounting and once it finds a match to the first ID in column C of "Book1.xls" it will loop through and match up all available column C data from Workbook A to the workbook it finds in the search. Moving the found file S,T columns to the Book1.xls D and E columns.

Or at least it should.

Sub SearchandDostuff()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'dimension variables
Dim wb As Workbook, wbCheck As Workbook, strID As String
Dim wsTO As Worksheet, wsFROM As Worksheet, i As Long, pos As Long
Dim folder As String, file As String, Path As String
Dim c As Range, rngMatch As Range, a As Range, rngFrom As Range
'folder to loop through
folder = "C:\Accounting"
'set destination info
Set wsTO = Workbooks("Book1.xls").Sheets("Sheet1") '<<== name your file and sheet

strID = Sheets("Sheet1").Range("C2").Text '<=name sheet properly
'Start FileSearch
With Application.FileSearch
.LookIn = folder
.Filename = "*.xls"
.FileType = msoFileTypeExcelWorkbooks
.SearchSubFolders = False
.Execute
If .Execute > 0 Then
'loop through all found files
For i = 1 To .FoundFiles.Count
'set incidental variables
pos = InStrRev(.FoundFiles(i), "\")
file = Right(.FoundFiles(i), Len(.FoundFiles(i)) - pos)
Path = Left(.FoundFiles(i), pos)
'check if workbook is open. if so, set variable to it, else open it
If IsWbOpen(file) Then
Set wb = Workbooks(file)
Else
Set wbCheck = Workbooks.Open(Path & file)
End If


'set worksheets to copy data from
Set wsFROM = wb.Sheets(1)
Set rngFrom = wsFROM.Range(Cells(1, 3), Cells(Rows.Count, 3)).End(xlUp)
''check for the ID column?
Set c = rngFrom.Find(strID) 'if a match is found we have the right workbook
If Not c Is Nothing Then 'if a match is found
'copy data from S and T to D and E
'set the range of column C for source list to find
Set rngMatch = wsTO.Range(Cells(2, 3), Cells(Rows.Count, 3)).End(xlUp)

For Each a In rngMatch
Set c = rngFrom.Find(strID)
If Not c Is Nothing Then 'if we have a match then
a.Offset(0, 1).Resize(1, 2).Value = c.Offset(, 16).Resize(1, 2).Value
End If 'if a match isn't found, move on

Next a 'go to next cell in source list and search

GoTo Foundit
End If 'end If for the first check

Next i 'next file
End If
End With

NotFoundIt:
MsgBox "A match was not found in any workbook"

Foundit:

Set wsTO= Nothing: Set wsFROM = Nothing: Set a = Nothing
Set c = Nothing: Set wb = Nothing

Application.ScreenUpdating = False
Application.DisplayAlerts = False


End Sub
Function IsWbOpen(wbName As String) As Boolean
On Error Resume Next
IsWbOpen = Len(Workbooks(wbName).Name)
End Function

[gnod]

XLGibbs,

does your procedure is capable for multiple workbook? i think is looking for a macro to search in multiple workbook.. Or is it i just don't understand :banghead:

[XLGibbs]

The procedure is currently set to look for multiple workbooks, but the do the required data movement once it finds "the one" with the data.

I can be tweaked to run the procedure for every file it finds easily enough.

[linkjg]

Thanks for your response!

I'm having a problem running the macro. When I run it, it gives me this error message:

Run-time error '1004':
Method 'Range' of object '_Worksheet' failed

and highlights this row:
Set rngFrom = wsFROM.Range(Cells(1, 3), Cells(Rows.Count, 3)).End(xlUp)

If I know the matching ID number should be in column K on matching workbook in C:/Accounting, how can I specify that here?

Also, the matching workbook in C:/Accounting is worksheet 2. I tried changing

Set wsFROM = wb.Sheets(1)

to

Set wsFROM = wb.Sheets(2)

but, it gives me the error message as:

Run-time error '91':
Object variable or With block variable not set

[XLGibbs]

Set rngFrom = wsFROM.Range(Cells(1, 3), Cells(Rows.Count, 3).End(xlUp))The parenthesis appears to be out of whack. see above correct syntax. The above line in the code also specifies which column to pull from, in this case column 3 which is Column C. if you need column K, that would be column number 11 so ti would be for column K

Set rngFrom = wsFROM.Range(Cells(1, 11), Cells(Rows.Count, 11).End(xlUp))

As far as the worksheet sets...

If the sheet you need to find is "Sheet2" then you can set
Set wsFROM = Sheets("Sheet2")

The index function doesn't necessarily correcate to the tab name, but the position in the file...I was stabbing at the dark on that Sheets(1) hoping you only 1 sheet in each file :)

[linkjg]

Thanks for helping me!! What if my sheet 2 is always named differently? But, that sheet 2 is the sheet where the match is found? Can the code specify that? :wot

[XLGibbs]

Err, maybe.

Sheet "2" is not "always" Sheet 2 though. There is the indexed order, and the code name value.

If you mean that each file it is the 2nd tab from left to right then yes, you can specify it like this:

Sheets(2)

but you said that gave you an error, indicating that that sheet does not exist in all the files...

[linkjg]

If you are online, could I send you a couple of sample files for you to see the problem?

[XLGibbs]

I am cooked for the night. Send me an email and I will take a look if I can tonight, or if not..tomorrow night.

Remember, I wrote that code completely on the fly, with no realistic way to test it...so I am still kind of flying blind here.

[linkjg]

You are so nice!! I'll attach an example with your code!

There are 100s of spreadsheets within the accounting folder, but they have the same column structure. Does the macro below close each file after it searches?

I really appreciate your help with this. It takes so long to find matches by hand! :(

[XLGibbs]

Ok, not a problem here. You told me column C, not column K for the ID column in the files to search.

Now, I think what you intend is for the code to:

1. Take 1 ID at a time from the list in Book1.xls
2. Search the entire accounting folder, each file, column K until it finds a match.
3. Once it finds a match, copy S,T from matching workbook to D,E of book1.xls.
4. Stop searching and go back to the list and get the next item to search again.

Is this correct?

[XLGibbs]

"you owe me"

Code below is attached in module one of Book1.xls file (attached)

Run the code, you will be prompted to point to the folder where the files are--once you hit okay, it will turn and burn.

For each ID in the list, it will search every file until it finds a match (or not)
If it finds a match, it will copy the data as prescribed. However, while my code worked as prescribed, no matches were found from your sample list in the files you provided--let me know if I need to tweek the ID search.

Sub SearchandDostuff()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'dimension variables
Dim wb As Workbook, wbCheck As Workbook, strID As String
Dim wsTO As Worksheet, wsFROM As Worksheet, i As Long, pos As Long
Dim folder As String, file As String, Path As String
Dim c As Range, rngMatch As Range, a As Range, rngFrom As Range
Dim Matched As Boolean, ID As Range, counter As Integer

'folder to loop through
folder = BrowseForFolder

'set destination info
Set wsTO = Workbooks("Book1.xls").Sheets("Sheet1") '<<== name your file and sheet

'set the range list, can be re-written to Range("C2:C100") and set to fit
With wsTO
Set rngMatch = .Range("C2:C" & .Cells(.Rows.Count, 3).End(xlUp).Row)
End With
MsgBox rngMatch.Address
For Each ID In rngMatch

Matched = False
'Start FileSearch
With Application.FileSearch
.LookIn = folder
.Filename = "*.xls"
.FileType = msoFileTypeExcelWorkbooks
.SearchSubFolders = False
.Execute
If .Execute > 0 Then
'loop through all found files
For i = 1 To .FoundFiles.Count
'set incidental variables
pos = InStrRev(.FoundFiles(i), "\")
file = Right(.FoundFiles(i), Len(.FoundFiles(i)) - pos)
Path = Left(.FoundFiles(i), pos)

'check if workbook is open. if so, set variable to it, else open it
If IsWbOpen(file) Then
Set wb = Workbooks(file)
If wb.Name = ThisWorkbook.Name Then GoTo SkipME
Else
Set wbCheck = Workbooks.Open(Path & file)
End If

Dim shchk As Boolean
shchk = False
With wb

'set worksheets to look in and if matched copy data from S,T to D,E
'find the sheet with SET in the left side of the name
For Each s In Worksheets
If UCase(Left(s.Name, 3)) = "SET" Then
Set wsFROM = Sheets(s.Name)
shchk = True
Exit For
End If
Next s

End With
If shchk = False Then GoTo SkipME
strID = ID.Text
Set rngFrom = wsFROM.Range(Cells(2, 11), Cells(Rows.Count, 11).End(xlUp))
''check for the ID column?
Set c = rngFrom.Find(strID) 'if a match is found we have the right workbook
If Not c Is Nothing Then 'if a match is found
'copy data from S and T to D and E
'set the range of column C for source list to find
ID.Offset(, 1).Resize(1, 2) = c.Offset(, 8).Resize(1, 2)
Matched = True

End If 'end If for the first check
If Matched = True Then Exit For 'if a match is found, exit file search loop
SkipME:
wb.Close False
Next i 'next file
End If

End With 'end with application filesearch
Next ID 'go to the next ID


Set wsTO = Nothing: Set wsFROM = Nothing: Set a = Nothing
Set c = Nothing: Set wb = Nothing

Application.ScreenUpdating = False
Application.DisplayAlerts = False


End Sub
Function IsWbOpen(wbName As String) As Boolean
On Error Resume Next
IsWbOpen = Len(Workbooks(wbName).Name)
End Function

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'''Code from kpuls, www.VBAExpress.com..portion (http://www.VBAExpress.com..portion) of Knowledge base submission

Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

Set ShellApp = Nothing

Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select

Exit Function
Invalid:

End Function

[linkjg]

Yes!! You are totally correct! I can't wait to try this out!! THANKS SO MUCH!!!!! Oh, I'm surprised that the trial didn't find a match. Those were all matches on the workbooks... hmm...can you tweak the ID search?

[XLGibbs]

Well, if there were supposed to be matches, and there weren't any..I will have to see what is up, but that means the ID I am looking for doesn't match the ID's in column K of the workbooks being searched.

Are the fields Identically matched? or is the list to search from only a partial?

[linkjg]

Thanks! The list to search is a partial list. It contains IDs from each of the sheets, in no particular order. Usually the Book1 IDs are a mixture of IDs from sheets in the C:/Accounting folder. For example, the first ID on the Book1.xls is a match on the Raxpir.xls workbook.

Again, I appreciate your help with this!!!

[XLGibbs]

What I mean is, is the ID in the search list a complete ID, not a complete list.

Would there be any extra characters in the Accounting folder files? If there is a match, my code should find them

[linkjg]

Yes, the ID on the search list (Book1.xls) is a complete ID. That is how the IDs look.

For example, the ID sm$abed6c25d0bf0b78:-5b3b6ad1:10ebe3d7ce7:-7fdf
from Book 1, matches the id on the Raxpir list. It is found at K11. So, the information on that row next to the id (columns S and T) would need to be placed on Book1.xls columns D and E.

I'll run your macro and see if it catches that! Thanks!!

Update: I ran the macro, but it didn't work.. :-( It gave me an error message and highlighted this row?

wb.Close False

[XLGibbs]

Yes, the ID on the search list (Book1.xls) is a complete ID. That is how the IDs look.

For example, the ID sm$abed6c25d0bf0b78:-5b3b6ad1:10ebe3d7ce7:-7fdf
from Book 1, matches the id on the Raxpir list. It is found at K11. So, the information on that row next to the id (columns S and T) would need to be placed on Book1.xls columns D and E.

I'll run your macro and see if it catches that! Thanks!!

Update: I ran the macro, but it didn't work.. :-( It gave me an error message and highlighted this row?

wb.Close False

Hmm. Should only run that on the Interior loop. Move that line so that it is just above the SKIPME: Line in the code

[linkjg]

I put it above the SKIPME, but it still is highlighting as an error? :(



wb.Close False
If Matched = True Then Exit For 'if a match is found, exit file search loop
SkipME:

[XLGibbs]

What exactly is the error. I do not get it with the samples you sent. 5 times in a row I tried it without the change and did not get the error.

[XLGibbs]

Okay, I figured out why the error occurred and fixed it. When I Set the workbook to open, I used a variable wbCheck instead of just wb, so there was no wb SET. This works and cycles through each ID in the list, and each workbook in succession, but I still don't get a match...so I am working on that issue now. This code works, I will advise when I get the trick for matching worked out.




Sub SearchandDostuff()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'dimension variables
Dim wb As Workbook, wbCheck As Workbook, strID As String
Dim wsTO As Worksheet, wsFROM As Worksheet, i As Long, pos As Long
Dim folder As String, file As String, Path As String
Dim c As Range, rngMatch As Range, a As Range, rngFrom As Range
Dim Matched As Boolean, ID As Range, counter As Integer

'folder to loop through
folder = BrowseForFolder

'set destination info
Set wsTO = Workbooks("Book1.xls").Sheets("Sheet1") '<<== name your file and sheet

'set the range list, can be re-written to Range("C2:C100") and set to fit
With wsTO
Set rngMatch = .Range("C2:C" & .Cells(.Rows.Count, 3).End(xlUp).Row)
End With
MsgBox rngMatch.Address
For Each ID In rngMatch

Matched = False
'Start FileSearch
With Application.FileSearch
.LookIn = folder
.Filename = "*.xls"
.FileType = msoFileTypeExcelWorkbooks
.SearchSubFolders = False
.Execute
If .Execute > 0 Then
'loop through all found files
For i = 1 To .FoundFiles.Count
'set incidental variables
pos = InStrRev(.FoundFiles(i), "\")
file = Right(.FoundFiles(i), Len(.FoundFiles(i)) - pos)
Path = Left(.FoundFiles(i), pos)

'check if workbook is open. if so, set variable to it, else open it
If IsWbOpen(file) Then
Set wb = Workbooks(file)
If wb.Name = ThisWorkbook.Name Then GoTo SkipME
Else
Set wb = Workbooks.Open(Path & file)
End If

Dim shchk As Boolean
shchk = False
With wb

'set worksheets to look in and if matched copy data from S,T to D,E
'find the sheet with SET in the left side of the name
For Each s In Worksheets
If UCase(Left(s.Name, 3)) = "SET" Then
Set wsFROM = Sheets(s.Name)
shchk = True
Exit For
End If
Next s

End With
If shchk = False Then GoTo SkipME
strID = ID.Text
Set rngFrom = wsFROM.Range(Cells(2, 11), Cells(Rows.Count, 11).End(xlUp))
''check for the ID column?
Set c = rngFrom.Find(strID) 'if a match is found we have the right workbook
If Not c Is Nothing Then 'if a match is found
'copy data from S and T to D and E
'set the range of column C for source list to find
ID.Offset(, 1).Resize(1, 2) = c.Offset(, 8).Resize(1, 2)
Matched = True

End If 'end If for the first check
If Matched = True Then Exit For 'if a match is found, exit file search loop
SkipME:

wb.Close False
Next i 'next file
End If

End With 'end with application filesearch
Next ID 'go to the next ID


Set wsTO = Nothing: Set wsFROM = Nothing: Set a = Nothing
Set c = Nothing: Set wb = Nothing

Application.ScreenUpdating = True
Application.DisplayAlerts = True


End Sub
Function IsWbOpen(wbName As String) As Boolean
On Error Resume Next
IsWbOpen = Len(Workbooks(wbName).Name)
End Function

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'''Code from kpuls, www.VBAExpress.com..portion of Knowledge base submission

Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

Set ShellApp = Nothing

Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select

Exit Function
Invalid:

End Function

[XLGibbs]

Okay, my friend. It works perfectly now. Solid matches and results as desired.

I removed the Msgbox rngID line and changed 1 line to get the matches to populate D,E in book1.xls with this line:

ID.Offset(, 1).Resize(1, 2) = c.Offset(, 8).Resize(1, 2)


becoming this: made all the difference (Doh!)
ID.Offset(, 1).Resize(1, 2) = c.Offset(, 8).Resize(1, 2).value

[linkjg]

Thanks for your help! It ran without errors, but it did not find the matches on the workbooks in C:/Accounting, even though the matches were there. :-(


When you ran the macro on your end, did it find matches? All of the IDs on the Book1.xls workbook are found on the C:/Accounting workbooks.

Thanks!!


Sub SearchandDostuff()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'dimension variables
Dim wb As Workbook, wbCheck As Workbook, strID As String
Dim wsTO As Worksheet, wsFROM As Worksheet, i As Long, pos As Long
Dim folder As String, file As String, Path As String
Dim c As Range, rngMatch As Range, a As Range, rngFrom As Range
Dim Matched As Boolean, ID As Range, counter As Integer

'folder to loop through
folder = BrowseForFolder

'set destination info
Set wsTO = Workbooks("Book1.xls").Sheets("Sheet1") '<<== name your file and sheet

'set the range list, can be re-written to Range("C2:C100") and set to fit
With wsTO
Set rngMatch = .Range("C2:C40" & .Cells(.Rows.Count, 3).End(xlUp).Row)
End With
For Each ID In rngMatch

Matched = False
'Start FileSearch
With Application.FileSearch
.LookIn = folder
.Filename = "*.xls"
.FileType = msoFileTypeExcelWorkbooks
.SearchSubFolders = False
.Execute
If .Execute > 0 Then
'loop through all found files
For i = 1 To .FoundFiles.Count
'set incidental variables
pos = InStrRev(.FoundFiles(i), "\")
file = Right(.FoundFiles(i), Len(.FoundFiles(i)) - pos)
Path = Left(.FoundFiles(i), pos)

'check if workbook is open. if so, set variable to it, else open it
If IsWbOpen(file) Then
Set wb = Workbooks(file)
If wb.Name = ThisWorkbook.Name Then GoTo SkipME
Else
Set wb = Workbooks.Open(Path & file)
End If

Dim shchk As Boolean
shchk = False
With wb

'set worksheets to look in and if matched copy data from S,T to D,E
'find the sheet with SET in the left side of the name
For Each s In Worksheets
If UCase(Left(s.Name, 3)) = "SET" Then
Set wsFROM = Sheets(s.Name)
shchk = True
Exit For
End If
Next s

End With
If shchk = False Then GoTo SkipME
strID = ID.Text
Set rngFrom = wsFROM.Range(Cells(2, 11), Cells(Rows.Count, 11).End(xlUp))
''check for the ID column?
Set c = rngFrom.Find(strID) 'if a match is found we have the right workbook
If Not c Is Nothing Then 'if a match is found
'copy data from S and T to D and E
'set the range of column C for source list to find
ID.Offset(, 1).Resize(1, 2) = c.Offset(, 8).Resize(1, 2).Value
Matched = True

End If 'end If for the first check
If Matched = True Then Exit For 'if a match is found, exit file search loop
SkipME:

wb.Close False
Next i 'next file
End If

End With 'end with application filesearch
Next ID 'go to the next ID


Set wsTO = Nothing: Set wsFROM = Nothing: Set a = Nothing
Set c = Nothing: Set wb = Nothing

Application.ScreenUpdating = True
Application.DisplayAlerts = True


End Sub
Function IsWbOpen(wbName As String) As Boolean
On Error Resume Next
IsWbOpen = Len(Workbooks(wbName).Name)
End Function

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'''Code from kpuls, www.VBAExpress.com..portion (http://www.vbaexpress.com..portion/) of Knowledge base submission

Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

Set ShellApp = Nothing

Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select

Exit Function
Invalid:

End Function

[XLGibbs]

Okay, my friend. It works perfectly now. Solid matches and results as desired.

I removed the Msgbox rngID line and changed 1 line to get the matches to populate D,E in book1.xls with this line:

ID.Offset(, 1).Resize(1, 2) = c.Offset(, 8).Resize(1, 2)

becoming this: made all the difference (Doh!)
ID.Offset(, 1).Resize(1, 2) = c.Offset(, 8).Resize(1, 2).value

Did you see this post? Once I made that change, it found the matches properly.

And yes, it worked perfectly for me hence the above response saying so..

[linkjg]

Could you repost the Book1 with the new, improved macro? Maybe I didn't make the changes correctly? :think:

[XLGibbs]

Okay..here it is.

[linkjg]

That's great! IT FOUND THE MATCHES!!! Awesome!! The only thing I noticed was that it kept the last workbook open in the end, it did not close it after running the macro. Is there a way to close it as well?

Otherwise, this is a very handy macro to use!!!! THANKS!! :rotlaugh:

[XLGibbs]

I will give you 48 hours to figure out why that workbook stays open. ;)

It is the least you can do since I did the rest.

[linkjg]

I totally agree!! I will look into that!! I really appreciate your help with this... you've done enough!! :bow:

[XLGibbs]

My pleasure. I cant count how many times I have adapted that same base code for various search and destroy missions. It comes in pretty handed. If you like, please rate the thread and mark it solved. Thanks!