CODEWITHSUNDEEP
excelvbaloopsfind
user2952447
user2952447

Reputation: 139

Search 1000 numbers in 1000 workbooks

I've looked for quite a bit for a macro/code to help me do this, and though I've found several hints around it, I couldn't find a solution. Maybe it's my inexperience with vba or that it's a unique situation that I haven't been able to customise these codes to work for me. As you can hopefully see from the other questions I've asked, I always try to attempot a solution before posting here, but this is situation which I've genuinely struggled with and hope it is something simple that you can help me with.

"DirectoryA\A",
"DirectoryA\B",
"DirectoryA\C",
"DirectoryA\D",
"DirectoryA\E",
"DirectoryA\F",
"DirectoryA\G",
"DirectoryA\H",
"DirectoryA\I",
"DirectoryA\J"

Thanks as always.

Upvotes: 0

Views: 69

Answers (1)

brettdj
brettdj

Reputation: 55682

Here is one option that

  • should be placed inside the Workbook that contains the numbers in Column A of Sheets
  • it looks through the first columns of all files in a specified folder, searching for each of the numbers in column A
  • any found numbers are returned from column B of the searched file
  • these are appended in a variant array of the original numbers
  • the variant array is dumped to a new sheet in the current workbook, then split into columns using TexttoColumns

If this does want you want it can be pointed multiple times at your 10 folders, or updated to loop through sub-folders of DirectoryA

code

Sub LoopThroughFiles()
Dim Wb As Workbook
Dim Wb2 As Workbook
Dim ws As Worksheet
Dim StrFile As String
Dim strDelim As String
Dim rng1 As Range
Dim rng2 As Range
Dim X
Dim Y
Dim lngCalc As Long
Dim lngCnt As Long

Set Wb = ThisWorkbook
Set ws = Wb.Sheets("Sheets1")
Set rng1 = ws.Range(ws.[a1], ws.Cells(Rows.Count, "A").End(xlUp))

If rng1 Is Nothing Then Exit Sub
X = rng1.Value2
Y = X
strDelim = ";"

With Application
.EnableEvents = False
.ScreenUpdating = False
lngCalc = .Calculation
.Calculation = xlManual
End With

StrFile = Dir("c:\temp\*.xls*")
Do While Len(StrFile) > 0
Set Wb2 = Workbooks.Open("c:\temp\" & StrFile)
For lngCnt = 1 To UBound(X)
    If Len(lngCnt) > 0 Then
        If IsNumeric(lngCnt) Then
            Set rng2 = Wb2.Sheets(1).Columns(1).Find(X(lngCnt, 1), , xlValues, xlWhole)
             If Not rng2 Is Nothing Then
                Y(lngCnt, 1) = Y(lngCnt, 1) & ";" & rng2.Offset(0, 1)
             End If
        End If
    End If
Next
    StrFile = Dir
    Wb2.Close False
Loop

Set ws = Wb.Sheets.Add
ws.[a1].Resize(UBound(X), 1).Value2 = Y
ws.Columns(1).TextToColumns ws.[a1], xlDelimited, , True, Other:=True

With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = lngCalc
End With

End Sub

Upvotes: 1

Related Questions