Daily, I need to check serial numbers to see whether it is invoiced. We have a system that generates the invoices and exports in the C:\Serial_Numbers location path, and the invoice number is always fixed to column A side to its serial number in column B.
I tried to google a VBA code to help me and tried this, which is doing a great job, as shown in the first picture: call-tab-and-then-enter-keys-in-an-excel-vba-module and https://www.get-digital-help.com/search-all-workbooks-in-a-folder-and-sub-folders/
The main problem in this VBA is that it needs a manually select one serial (string) and get the result in a new sheet.
Edit: I tweaked the code with my limited knowledge to have the search result on the same sheet and fixed the search directory folder (first Answer), but each time I tried to loop the code in all column A serial numbers, I ended up with many errors.
'Dimensioning public variable and declaring the data type
'A Public variable can be accessed from any module, Sub Procedure, Function, or Class within a specific workbook.
Public WS As Worksheet
'Name macro and parameters
Sub SearchWKBooksSubFolders(Optional Folderpath As Variant, Optional Str As Variant)
'Dimension variables and declare data types
Dim myfolder As String
Dim a As Single
Dim sht As Worksheet
Dim Lrow As Single
Dim Folders() As String
Dim Folder As Variant
'Redimension array variable
ReDim Folders(0)
'IsMissing returns a Boolean value indicating if an optional Variant parameter has been sent to a procedure.
'Check if FolderPath has not been sent
If IsMissing(Folderpath) Then
'Add a worksheet
Set WS = Sheets.Add
'Ask for a folder to search.
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
myfolder = .SelectedItems(1) & "\"
End With
'Ask for a search string.
Str = Application.InputBox(prompt:="Search string:", Title:="Search all workbooks in a folder", Type:=2)
'Stop macro if no search string is entered.
If Str = "" Then Exit Sub
'Save "Search string:" to cell "A1".
WS.Range("A1") = "Search string:"
'Save variable Str to cell "B1".
WS.Range("B1") = Str
'Save "Path:" to cell "A2".
WS.Range("A2") = "Path:"
'Save variable myfolder to cell "B2".
WS.Range("B2") = myfolder
'Save "Folderpath" to cell "A3".
WS.Range("A3") = "Folderpath"
'Save "Workbook" to cell "B3".
WS.Range("B3") = "Workbook"
'Save "Worksheet" to cell "C3".
WS.Range("C3") = "Worksheet"
'Save "Cell Address" to cell "D3".
WS.Range("D3") = "Cell Address"
'Save "Link" to cell "E3".
WS.Range("E3") = "Link"
'Save variable myfolder to variable Folderpath
Folderpath = myfolder
'Dir returns a String representing the name of a file, directory, or folder that matches a specified pattern or file attribute, or the volume label of a drive.
Value = Dir(myfolder, &H1F)
'Continue here if FolderPath has been sent
Else
'Check if the two last characters in Folderpath is "//".
If Right(Folderpath, 2) = "\\" Then
'Stop macro
Exit Sub
End If
'Dir returns a String representing the name of a file, directory, or folder that matches a specified pattern or file attribute, or the volume label of a drive.
Value = Dir(Folderpath, &H1F)
End If
'Keep iterating until Value is nothing
Do Until Value = ""
'Check if Value is . or ..
If Value = "." Or Value = ".." Then
'Continue here if Value is not . or ..
Else
'Check if Folderpath & Value is a folder
If GetAttr(Folderpath & Value) = 16 Then
'Add folder name to array variable Folders
Folders(UBound(Folders)) = Value
'Add another container to array variable Folders
ReDim Preserve Folders(UBound(Folders) + 1)
'Continue here if Value is not a folder
'Check if the file ends with xls, xlsx, or xlsm
ElseIf Right(Value, 3) = "xls" Or Right(Value, 4) = "xlsx" Or Right(Value, 4) = "xlsm" Then
'Enable error handling
On Error Resume Next
'Check if the workbook is password protected.
Workbooks.Open fileName:=Folderpath & Value, Password:="zzzzzzzzzzzz"
'Check if an error has occurred
If Err.Number <> 0 Then
'Write the workbook name and the phrase "Password protected."
WS.Range("A4").Offset(a, 0).Value = Value
WS.Range("B4").Offset(a, 0).Value = "Password protected"
'Add 1 to variable 1
a = a + 1
'Disable error handling
On Error GoTo 0
'Continue here if an error has not occurred
Else
'Iterate through all worksheets in the active workbook
For Each sht In ActiveWorkbook.Worksheets
'Expand all groups in a sheet
sht.Outline.ShowLevels RowLevels:=8, ColumnLevels:=8
'Search for cells containing search string and save to variable c
Set c = sht.Cells.Find(Str, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
'Check if variable c is not empty
If Not c Is Nothing Then
'Save cell address to variable firstAddress
firstAddress = c.Address
'Do ... Loop While c is not nothing
Do
'Save the row of the last non-empty cell in column A
Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row
'Save folderpath to the first empty cell in column A in worksheet WS
WS.Range("A1").Offset(Lrow, 0).Value = Folderpath
'Save value to the first empty cell in column B in worksheet WS
WS.Range("B1").Offset(Lrow, 0).Value = Value
'Save the worksheet name to the first empty cell in column C in worksheet WS
WS.Range("C1").Offset(Lrow, 0).Value = sht.Name
'Save cell address to the first empty cell in column D in worksheet WS
WS.Range("D1").Offset(Lrow, 0).Value = c.Address
'Insert hyperlink
WS.Hyperlinks.Add Anchor:=WS.Range("E1").Offset(Lrow, 0), Address:=Folderpath & Value, SubAddress:= _
"'" & sht.Name & "'" & "!" & c.Address, TextToDisplay:="Link"
'Find next cell containing search string and save to variable c
Set c = sht.Cells.FindNext(c)
'Continue iterate while c is not empty and the cell address is not equal to the first cell address.
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
'Continue with the next worksheet
Next sht
End If
'Close workbook
Workbooks(Value).Close False
'Disable error handling
On Error GoTo 0
End If
End If
Value = Dir
Loop
'Go through all folder names and
For Each Folder In Folders
'start another instance of macro SearchWKBooksSubFolders (recursive)
SearchWKBooksSubFolders (Folderpath & Folder & "\")
Next Folder
'Resize column widths
Cells.EntireColumn.AutoFit
End Sub
The current result
Expected results
