Excel: How to search multiple workbooks for Cell information
This code will work in the following way:
- Open a new workbook wherever you want.
- Paste the VBA code on Macro
On Sheet 1 cell A1 put the path to the folder of workbooks, for example:
C:\users\yourname\folder\
On Cell A2 the first range for example:
J8:Y8
and on Cell B2 the Sheet name:Sheet3
- On Cell A3 the second range for example:
G8:AC8
and on Cell B3 the Sheet name:Sheet4
The best of this code is that if you have more ranges/sheets to search you can add on the next rows.
It will look like this:
Now, execute the macro and after its execution it will show the results on Sheet2, showing the name of the file and the number of empty cells on each range.
Sub foldersearch()
Dim wbk As Workbook
Dim wbk1 As Workbook
Dim wks As Worksheet
Dim wks2 As Worksheet
Dim totaltime As Long
Dim dtDuration As Date
Set wbk = ThisWorkbook
Set wks = wbk.Sheets(1)
Set wks2 = wbk.Sheets(2)
starttime = Now()
wks2.Cells.ClearContents
dirPath = wks.Cells(1, 1)
file = Dir(dirPath)
rowscounter = 0
Application.ScreenUpdating = False
While (file <> "")
If InStr(file, "xls") > 0 Then
rowscounter = rowscounter + 1
totalpath = dirPath & file
Set wbk1 = Workbooks.Open(totalpath, , True)
rangelist = True
i = 2
columnscounter = 2
While rangelist = True
thenewrango = wks.Cells(i, 1)
thenewsheet = wks.Cells(i, 2)
emptycount = workbooksearch(wbk1, thenewsheet, thenewrango)
wks2.Cells(rowscounter, 1) = file
wks2.Cells(rowscounter, columnscounter) = emptycount
i = i + 1
columnscounter = columnscounter + 1
If wks.Cells(i, 1) = "" Then
rangelist = False
End If
Wend
wbk1.Close (False)
End If
file = Dir
Wend
Application.ScreenUpdating = True
endtime = Now()
totaltime = DateDiff("s", starttime, endtime)
a = MsgBox("Finished in" & vbCrLf & totaltime & " seconds", vbOKOnly)
End Sub
Function workbooksearch(wbk1 As Workbook, wksname As Variant, rango As Variant)
Dim wks1 As Worksheet
Dim obj As Object
On Error GoTo HandleError
Set obj = wbk1.Sheets(wksname)
Set wks1 = wbk1.Worksheets(wksname)
emptycount = 0
For Each c In wks1.Range(rango)
If c.Value = "" Then
emptycount = emptycount + 1
End If
Next c
workbooksearch = emptycount
Exit Function
HandleError:
workbooksearch = "N/A"
End Function
Related videos on Youtube
Christopher Olly Oliver
Updated on September 18, 2022Comments
-
Christopher Olly Oliver over 1 year
Currently we receive e-forms filled out with Excel from our customers, so I have a folder filled with workbooks.
Each workbook has multiple sheets.
I need to search through each of the workbooks to see if range "J8:Y8 on Sheet3" and "G8:AC8 on Sheet 4" has been filled in as these need further scrutiny, but only a few will have those sheets completed.
Also, each workbook has been named something completely different.
I have found this code (below) online which in principle does what I need. However, it searches every sheet of the workbook for a specific "Value".
Sub SearchFolders() Dim fso As Object Dim fld As Object Dim strSearch As String Dim strPath As String Dim strFile As String Dim wOut As Worksheet Dim wbk As Workbook Dim wks As Worksheet Dim lRow As Long Dim rFound As Range Dim strFirstAddress As String On Error GoTo ErrHandler Application.ScreenUpdating = False 'Change as desired strPath = "c:\MyFolder" strSearch = "Specific text" Set wOut = Worksheets.Add lRow = 1 With wOut .Cells(lRow, 1) = "Workbook" .Cells(lRow, 2) = "Worksheet" .Cells(lRow, 3) = "Cell" .Cells(lRow, 4) = "Text in Cell" Set fso = CreateObject("Scripting.FileSystemObject") Set fld = fso.GetFolder(strPath) strFile = Dir(strPath & "\*.xls*") Do While strFile <> "" Set wbk = Workbooks.Open _ (Filename:=strPath & "\" & strFile, _ UpdateLinks:=0, _ ReadOnly:=True, _ AddToMRU:=False) For Each wks In wbk.Worksheets Set rFound = wks.UsedRange.Find(strSearch) If Not rFound Is Nothing Then strFirstAddress = rFound.Address End If Do If rFound Is Nothing Then lRow = lRow + 1 .Cells(lRow, 1) = wbk.Name .Cells(lRow, 2) = wks.Name .Cells(lRow, 3) = rFound.Address .Cells(lRow, 4) = rFound.Value Else Exit Do End If Set rFound = wks.Cells.FindNext(After:=rFound) Loop While strFirstAddress <> rFound.Address Next wbk.Close (False) strFile = Dir Loop .Columns("A:D").EntireColumn.AutoFit End With MsgBox "Done" ExitHandler: Set wOut = Nothing Set wks = Nothing Set wbk = Nothing Set fld = Nothing Set fso = Nothing Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description, vbExclamation Resume ExitHandler End Sub
-
Raystafarian about 9 yearsSo you've found something that does what you want, but also does something else? What have you tried changing? Why? What happens? Where are you stuck?
-
Engineer Toast about 9 yearsProbably, the only pieces you want out of this code are the bits that open each workbook in a folder. (You may want to keep the results page that it creates if apply the additional scrutiny via organic inspection.)
-