Use Excel File List to find matches in Excel Files and Copy to new Excel Document

Ok I have around 5,000 ID numbers in an excel file and need to see if they match any of the numbers in (currently 3) 3 different Excel files containing about 650 lines each. The files are setup basically the same with Column B containing the ID numbers I want to match to. Basically I'm trying to do this:

Procedural Code:

1. Open Master Excel File containing all of the numbers I want to try to match in the other 3 files. (Contains Variable set of numbers to match all in column A)
2. Open workbook1, see if Column B contains a match for first number in Master Excel File (Cell A1).
3. Open workbook2, see if Column B contains a match for first number in Master Excel File (Cell A1)
4. Open next workbook, etc etc.
5. If a match is found, In the master workbook next to the ID number, copy the Workbook name it was found in to Column B. In column C the macro should paste the CELL that the number was found in (As long as I have the line number). If multiple matches are found (in more than 1 workbook, it should see if Column B is blank, if not, it should insert a comma after the existing filename and insert the next found location).

The Master File should end up looking like this:
COLUMN A COLUMN B COLUMN C
10020301 Workbook1 B700
14242523 Workbook3,Workbook4 B234
23256232 Workbook1 B633


The number of workbooks im searching through may change. So i'd like it to be variable (based on a specific directory, rather than workbook names). Made to search through every workbook in a specific folder.

If anyone already has this code they are using (or anything very simular) please paste it. If anyone feels like helping me out with some code I would really appreciate it. I am at work right now, and I have to get these done as soon as possible as it may pertain to a product recall. (Im matching serial numbers for certain criteria) I am quite decent at programming when I have existing code to work with, but I'm least familiar with VB and I haven't used it in a few years. (Certainly not good at making it effecient).

Thanks for any help anyone can give me. This is a DAUNTING task to try to do without a macro. Will probably take me every night all night for the next couple of weeks to do without a macro to help. If I can make a macro, I can just type all of the serial numbers into the main excel file and have all of the data matches come up beside them then I can just type in the information that is needed only on the ones that match hopefully reducing the number of serials I have to enter data for. And also making it really easy to find the lines I need to enter the data at.

Here is the code im currently trying to modify. Anyone good at excel who could quickly fix it up to do whats in the original post gets many kudos!


Sub Extract_Totals()

Dim SEARCHSTRING As String
SEARCHSTRING = "10145023"

Dim mWorkbooks() As String, mNumberOfWorkbooks As Long, mWorkbookCounter As Long

Dim mValuesFound() As Double, mValueFoundCounter As Long, mCounter As Long
Dim mWorkbookFoundIn() As String
Dim mWorksheetFoundIn() As String

Dim ValueOFFSET_Row As Long
Dim ValueOFFSET_Col As Long
Dim mSheetCount As Long, mSheetCounter As Long
Dim mFoundAddress As String

mNumberOfWorkbooks = 3
ReDim mWorkbooks(1 To mNumberOfWorkbooks)

mWorkbooks(1) = "P:\Telesis Numbers\Suspension Welder D-Side Data.xls"
mWorkbooks(2) = "P:\Telesis Numbers\SW 3E macro telesis 6-17-10.xls"
mWorkbooks(3) = "P:\Telesis Numbers\SW2A penetration 6-15-10.xls"


ValueOFFSET_Row = 0
ValueOFFSET_Col = 1


mWorkbookCounter = 1
For mWorkbookCounter = 1 To 3
Workbooks.Open Filename:=mWorkbooks(mWorkbookCounter)

mSheetCount = ActiveWorkbook.Sheets.Count
For mSheetCounter = 1 To mSheetCount
Sheets(mSheetCounter).Select

Range("B1").Select
mFoundAddress = ""
On Error Resume Next
mFoundAddress = Cells.Find(What:=SEARCHSTRING, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Address
On Error GoTo 0


If mFoundAddress <> "" Then
mValueFoundCounter = mValueFoundCounter + 1

ReDim Preserve mValuesFound(1 To mValueFoundCounter)
mValuesFound(mValueFoundCounter) = ActiveSheet.Range(mFoundAddress).Offset(ValueOFFSET_Row, ValueOFFSET_Col).Value

ReDim Preserve mWorkbookFoundIn(1 To mValueFoundCounter)
mWorkbookFoundIn(mValueFoundCounter) = mWorkbooks(mWorkbookCounter)

ReDim Preserve mWorksheetFoundIn(1 To mValueFoundCounter)
mWorksheetFoundIn(mValueFoundCounter) = ActiveSheet.Name

End If


Next mSheetCounter
ActiveWindow.Close


Next mWorkbookCounter


Dim mMSG As String
mMSG = "Values :" & vbCr & vbCr
If mValueFoundCounter = 0 Then mMSG = mMSG & "NO VALUES FOUND"
For mCounter = 1 To mValueFoundCounter
mMSG = mMSG & mWorkbookFoundIn(mCounter) & vbTab
mMSG = mMSG & mWorksheetFoundIn(mCounter) & vbTab
mMSG = mMSG & mValuesFound(mCounter)
mMSG = mMSG & vbCr
Next mCounter

MsgBox mMSG
End Sub

Ok, just so in the future if someone has the same need, here is the working code to do this. (Note that it could use some SERIOUS optimization, which I am going to do to mine and I'll post that version when its done)

So anyway, heres basically the whole kitten kabootle...


Sub Extract_Totals()

'Current Limitations:
' Will not currently find more than 1 result per file checked for a given Telesis number.


'Loop through Telesis Records to find
Dim SEARCHSTRING As String
Dim x As Integer
Dim total_rows As Integer
Dim RunningLocation As String
Dim COMMAND_count As Integer

COMMAND_count = 0

ThisWorkbook.Activate
Sheets("Sheet1").Select
'/////////////////////////////////////////////////////////////////
'//////////////// SPECIFY THE RANGE HERE /////////////////////////
total_rows = Range("$A$1", "$A$500").Count
'/////////////////////////////////////////////////////////////////
'/////////////////////////////////////////////////////////////////

For x = 1 To total_rows
ThisWorkbook.Activate
Sheets("Sheet1").Select
temp = "$A$" & x
Range(temp).Activate
SEARCHSTRING = ActiveCell.Value
If SEARCHSTRING = "" Then
End
End If

Dim mWorkbooks() As String, mNumberOfWorkbooks As Long, mWorkbookCounter As Long

Dim mValuesFound() As String, mValueFoundCounter As Long, mCounter As Long
Dim mWorkbookFoundIn() As String
Dim mWorksheetFoundIn() As String

Dim ValueOFFSET_Row As Long
Dim ValueOFFSET_Col As Long
Dim mSheetCount As Long, mSheetCounter As Long
Dim mFoundAddress As String

mNumberOfWorkbooks = 3
ReDim mWorkbooks(1 To mNumberOfWorkbooks)

mWorkbooks(1) = "P:\Telesis Numbers\file1.xls"
mWorkbooks(2) = "P:\Telesis Numbers\file2.xls"
mWorkbooks(3) = "P:\Telesis Numbers\file3.xls"


ValueOFFSET_Row = 0
ValueOFFSET_Col = 1


mWorkbookCounter = 1

For mWorkbookCounter = 1 To 3
Workbooks.Open Filename:=mWorkbooks(mWorkbookCounter)

'REMOVED FROM HERE

'mSheetCount = ActiveWorkbook.Sheets.Count
For mSheetCounter = 1 To 1 'mSheetCount
Sheets(mSheetCounter).Activate

Range("B:B").Select
mFoundAddress = ""
On Error Resume Next
mFoundAddress = Cells.Find(What:=SEARCHSTRING, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Address
On Error GoTo 0


If mFoundAddress <> "" Then
mValueFoundCounter = mValueFoundCounter + 1

ReDim Preserve mValuesFound(1 To mValueFoundCounter)
mValuesFound(mValueFoundCounter) = mFoundAddress
'mValuesFound(mValueFoundCounter) = ActiveSheet.Range(mFoundAddress).Offset(ValueOFFSET_Row, ValueOFFSET_Col).Value

ReDim Preserve mWorkbookFoundIn(1 To mValueFoundCounter)
mWorkbookFoundIn(mValueFoundCounter) = ActiveWorkbook.Name
'mWorkbookFoundIn(mValueFoundCounter) = mWorkbooks(mWorkbookCounter)

ReDim Preserve mWorksheetFoundIn(1 To mValueFoundCounter)
mWorksheetFoundIn(mValueFoundCounter) = ActiveSheet.Name

End If

ActiveWindow.Close
If mFoundAddress <> "" Then
COMMAND_count = COMMAND_count + 1
RunningLocation = "$A$" & COMMAND_count
ThisWorkbook.Activate
Sheets("Sheet2").Select
Range(RunningLocation).Activate
ActiveCell.Value = SEARCHSTRING
ActiveCell.Offset(0, 1) = mValuesFound(mValueFoundCounter)
ActiveCell.Offset(0, 2) = mWorkbookFoundIn(mValueFoundCounter)
ActiveCell.Offset(0, 3) = mWorksheetFoundIn(mValueFoundCounter)
End If

Next mSheetCounter

Next mWorkbookCounter

Next x

End Sub