VBA search closed workbook(s) for value?

Question

I am trying to search all excel workbooks in a folder (and sub folders) for a value.

My folder structure where my excel workbooks are is like so:

destPath = "G:\WH DISPO\(3) PROMOTIONS\(18) Food Specials Delivery Tracking\Archive\"

Then within my archive folder there are various sub folders like

+ 2017
- April
- May

+ 2016
- April
- May

The names of the workbooks might all be different, so the code will need to probably use something like wildcards *.xlsm

Here's what i have so far:

Sub Search()
Dim srcWorkbook As Workbook
    Dim destWorkbook As Workbook
    Dim srcWorksheet As Worksheet
    Dim destWorksheet As Worksheet
    Dim SearchRange As Range
    Dim destPath As String
    Dim destname As String
    Dim destsheet As String
    Set srcWorkbook = ActiveWorkbook
    Set srcWorksheet = ActiveSheet
    Dim vnt_Input As String

    vnt_Input = Application.InputBox("Please Enter Client Name", "Client Name")

    destPath = "G:\WH DISPO\(3) PROMOTIONS\(18) Food Specials Delivery Tracking\Archive\"
    destname = "*.xlsm"


    On Error Resume Next
    Set destWorkbook = ThisWorkbook
    If Err.Number <> 0 Then
    Err.Clear
    Set wbTarget = Workbooks.Open(destPath & destname)
    CloseIt = True
    End If

    For Each c In wbTarget.Sheets(1).Range("A:Q") 'No need for the .Cells here

       If InStr(c, vnt_Input) > 0 Then 'vnt_Input is a variable that holds a string, so you can't put quotes around it, or it will search the string for "vnt_Input"

          MsgBox "Found"
       End If
    Next c

End Sub

The ranges in each workbook should always stay the same.

I am trying something simple, like display a message when the value is found. But at the moment, despite the value existing in the workbook i am getting no result/no message.

I get an object required error on this line:

For Each c In wbTarget.Sheets(1).Range("A:Q") 'No need for the .Cells here

Please can someone show me where i am going wrong?

EDIT:

Can i change the message box to a for each loop to list each result like so:

Dim i As Integer
For i = 20 To 100

For Each rngFound In rngFound

ThisWorkbook.ActiveSheet.Range("E" & i).Value = "1 Result found for " & rngFound & " in " & wbTarget.Path & "\" & wbTarget.Name & ", on row " & rngFound.Address

Next rngFound

Next i

Desired Result

Write `Option Explicit` on the top, then try to debug it. You have to define `CloseIt` and `c` and probably something else. http://stackoverflow.com/questions/1139321/how-do-i-force-vba-access-to-require-variables-to-be-defined — Vityata, Apr 20 '17 at 09:22
It might be better to collect all the locations in a string and print them at the end, or do you want to stop each time and do stuff once you find the value? It would be difficult to stop mid code and update the worksheet if this is the functionality you need. — Preston, Apr 20 '17 at 09:22
@tompreston in terms of functionality i would just like a message to display giving the name and file path of the workbook with the value in it — user7415328, Apr 20 '17 at 09:24

SteveES · Accepted Answer · 2017-04-20T14:29:58.893

The way your code is set up won't work. You cannot use the Workbooks.Open() method with a wildcard, as it will only open one file at a time and doesn't search for a file. There are two ways of searching through a directory for a file with a particular naming pattern that I know of. The easiest way is using the Dir() function, but this won't recurse into subfolders very easily.

The second way (coded out for you below) is a way of recursing through files and subfolders that uses the FileSystemObject. In order to use this, you will need to add a reference to your project to the Microsoft Scripting Runtime library. You add the reference via Tools->References.

Also note that this method uses the Range.Find() method to find the client name in your workbooks as it should be quicker and easier to understand than your current method of finding whether the client name is in the worksheet.

Option Explicit

Sub Search()

Dim myFolder As Folder
Dim fso As FileSystemObject
Dim destPath As String
Dim myClient As String

myClient = Application.InputBox("Please Enter Client Name", "Client Name")

Set fso = New FileSystemObject

destPath = "G:\WH DISPO\(3) PROMOTIONS\(18) Food Specials Delivery Tracking\Archive\"

Set myFolder = fso.GetFolder(destPath)

'Set extension as you would like
Call RecurseSubfolders(myFolder, ".xlsm", myClient)

End Sub

Sub RecurseSubfolders(ByRef FolderToSearch As Folder, _
           ByVal fileExtension As String, ByVal myClient As String)

Dim fileCount As Integer, folderCount As Integer
Dim objFile As File
Dim objSubfolder As Folder

fileCount = FolderToSearch.Files.Count
'Loop over all files in the folder, and check the file extension
If fileCount > 0 Then
  For Each objFile In FolderToSearch.Files
    If LCase(Right(objFile.Path, Len(fileExtension))) = LCase(fileExtension) Then
      'You can check against "objFile.Type" instead of the extension string,
      'but you would need to check what the file type to seach for is
      Call LookForClient(objFile.Path, myClient)
    End If
  Next objFile
End If

folderCount = FolderToSearch.SubFolders.Count
'Loop over all subfolders within the folder, and recursively call this sub
If folderCount > 0 Then
  For Each objSubfolder In FolderToSearch.SubFolders
    Call RecurseSubfolders(objSubfolder, fileExtension, myClient)
  Next objSubfolder
End If

End Sub

Sub LookForClient(ByVal sFilePath As String, ByVal myClient As String)

Dim wbTarget As Workbook
Dim ws As Worksheet
Dim rngFound As Range
Dim firstAddress As String
Static i As Long           'Static ensures it remembers the value over subsequent calls

'Set to whatever value you want
If i <= 0 Then i = 20

Set wbTarget = Workbooks.Open(Filename:=sFilePath)    'Set any other workbook opening variables as appropriate

'Loop over all worksheets in the target workbook looking for myClient
For Each ws In wbTarget.Worksheets
  With ws.Range("A:Q")
    Set rngFound = .Find(What:=myClient, LookIn:=xlValues, LookAt:=xlPart)

    If Not rngFound Is Nothing Then
      firstAddress = rngFound.Address

      'Loop finds all instances of myClient in the range A:Q
      Do
        'Reference the appropriate output worksheet fully, don't use ActiveWorksheet
        ThisWorkbook.Worksheets("SomeSheet").Range("E" & i).Value = _
                     "1 Result found for " & myClient & " in " & sFilePath _
                     & ", in sheet " & ws.Name & ", in cell " & rngFound.Address
        i = i + 1
        Set rngFound = .FindNext(After:=rngFound)
      Loop While (Not rngFound Is Nothing And rngFound.Address <> firstAddress)
    End If
  End With
Next ws

'Close the workbook
wbTarget.Close SaveChanges:=False

End Sub

thanks for this, works great. However is there a way i can change the message box to list each result? See Edit in question — user7415328, Apr 20 '17 at 13:56
Do you want to find the locations of multiple instances of `myClient` in a single worksheet/workbook? Or just the first instance of `myClient` in a workbook, but list each found workbook in the macro worksheet? — SteveES, Apr 20 '17 at 13:59
pleae see image uploaded in edit. I want to list each found value and the row, workbook path and name where each found value ocurred — user7415328, Apr 20 '17 at 14:02

Keith Swerling · Answer 2 · 2021-05-21T17:35:56.720

I needed to go through a list of job report files and search for either the client ID number OR a wildcard partial selection of the Company name if no client ID was known.

I cleaned up the Query to remove most of the extra unnecessary fields, and stopped there. I also intended to merge the 2 different queries into 1 program statement, but it fought me and I stopped there.

Make a sheet named "Output" for the temporary query placement. It is only copying the data result and not the header since I am stringing multiple results together. You will need to of course Record a Macro and Data / Get Data / From File / From Workbook, open your workbook, Transform Data, pick your columns to return, and put in your search parameter on the column, and close and return to your spreadsheet, and finally stop the macro to get your own query.

    Sub XLDataScan()
    
       ' Send File path and Name of XL file, Specific data, OR Contains data to search for. 
       ExternalXLScan "PATH/FILENAME", "SPECIFIC_Data", "CONTAINS_Data"
    
    End Sub
    
    Sub ExternalXLScan (sPath As String, sSubID As String, sOrg As String)
    
        Dim DoSearch  As String
    
        Sheets("Output").Select
    
            ' The 2 data needed for either query is "sPath", which is the file to be checked, and the "sSubID" OR "sOrg".
           
            ' SPECIFIC or PARTIAL
        If sSubID <> "" Then
            DoSearch = "([Subscriber ID] = " & sSubID
        
            ActiveWorkbook.Queries.Add Name:="Add-On Pull", Formula:= _
            "let" & Chr(13) & "" & Chr(10) & "    Source = Excel.Workbook(File.Contents(""" & sPath & """), null, true)," & Chr(13) & "" & Chr(10) & "    #""Add-On Pull_Sheet"" = Source{[Item=""Add-On Pull"",Kind=""Sheet""]}[Data]," & Chr(13) & "" & Chr(10) & "    #""Promoted Headers"" = Table.PromoteHeaders(#""Add-On Pull_Sheet"", [PromoteAllScal" & _
            "ars=true])," & Chr(13) & "" & Chr(10) & "    #""Changed Type"" = Table.TransformColumnTypes(#""Promoted Headers"",{{""Pull Date"", type date}, {""Mail Date"", type date}, {""Job Line"", type any}, {""Account Name"", type text}, {""Account State"", type text}, {""Last Name"", type text}, {""Suffix"", type any}, {""First Name"", type text}, {""Middle Name"", type text}, {""Subscriber ID"", Int64" & _
            ".Type}, {""CertificateDeductibleperCoveredPerson"", type any}, {""CertificateDeductibleperFamily"", type any}})," & Chr(13) & "" & Chr(10) & "    #""Removed Other Columns"" = Table.SelectColumns(#""Changed Type"",{""Mail Date"", ""Account Name"", ""Last Name"", ""First Name"", ""Subscriber ID""})," & Chr(13) & "" & Chr(10) & "    #""Filtered Rows"" = Table.SelectRows(#""Removed " & _
            "Other Columns"", each " & DoSearch & "))" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Filtered Rows"""
      
        End If
        If sOrg <> "" Then
       ' Text.Contains([Account Name], ""Series"
            Debug.Print "sOrg: " & sOrg
            DoSearch = "Text.Contains([Account Name], """ & sOrg '"([Subscriber ID] = " & sOrg
    
            ActiveWorkbook.Queries.Add Name:="Add-On Pull", Formula:= _
            "let" & Chr(13) & "" & Chr(10) & "    Source = Excel.Workbook(File.Contents(""" & sPath & """), null, true)," & Chr(13) & "" & Chr(10) & "    #""Add-On Pull_Sheet"" = Source{[Item=""Add-On Pull"",Kind=""Sheet""]}[Data]," & Chr(13) & "" & Chr(10) & "    #""Promoted Headers"" = Table.PromoteHeaders(#""Add-On Pull_Sheet"", [PromoteAllScala" & _
            "rs=true])," & Chr(13) & "" & Chr(10) & "    #""Changed Type"" = Table.TransformColumnTypes(#""Promoted Headers"",{{""Pull Date"", type date}, {""Mail Date"", type date}, {""Job Line"", type any}, {""Account Name"", type text}, {""Account State"", type text}, {""Last Name"", type text}, {""Suffix"", type any}, {""First Name"", type text}, {""Middle Name"", type text}, {""Subscriber ID"", Int64." & _
            "Type},  {""CertificateDeductibleperFamily"", Int64.Type}})," & Chr(13) & "" & Chr(10) & "    #""Removed Other Columns"" = Table.SelectColumns(#""Changed Type"",{""Pull Date"", ""Account Name"", ""Last Name"", ""First Name"", ""Subscriber ID""})," & Chr(13) & "" & Chr(10) & "    #""Filtered Rows"" = Table.SelectRows(#""Re" & _
            "moved Other Columns"", each " & DoSearch & """))" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Filtered Rows"""
      
        End If
           
        With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
            "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""Add-On Pull"";Extended Properties=""""" _
            , Destination:=Range("$A$1")).QueryTable
            .CommandType = xlCmdSql
            .CommandText = Array("SELECT * FROM [Add-On Pull]")
'        .RowNumbers = True
            .ListObject.DisplayName = "Add_On_Pull"
            .Refresh BackgroundQuery:=False
        End With
        
        ' Remove Query and Connection
        KillQueries
    
            'If data, copy it over
        If Range("A2") <> "" Then
       
            ' Just copy data found, not including header
            Dim AllFound As Integer
            AllFound = Worksheets("Output").Range("A" & Rows.Count).End(xlUp).Row
    Workbooks("Transconnect_Production.xlsm").Worksheets("Output").Range("A2:E" & AllFound).Copy _
    Destination:=Workbooks("Transconnect_Production.xlsm").Worksheets("Find Mail Date").Range("B" & RowPlace + 1)
        
     Range("Add_On_Pull[#All]").Delete
    
        Sheets("Sheet1").Select
    
    End Sub
    
    
    
    Sub KillQueries()
        Dim xConnect As Object
    Dim cn As WorkbookConnection
    Dim qr As WorkbookQuery
    On Error Resume Next
    For Each cn In ThisWorkbook.Connections
        cn.Delete
    Next
    For Each qr In ThisWorkbook.Queries
        qr.Delete
    Next
    End Sub

score 0 · Answer 3 · answered Jun 02 '21 at 17:07

I updated my code to use ADO to query the closed workbooks. For 50 files searched this is about 10 seconds faster than the code I posted earlier, 40 seconds to complete versus about 50 seconds.

Sub XLDataScan()

   ' Send File path and Name of XL file, Specific data, OR Contains data to search for. 
   ExternalXLScan "PATH/FILENAME", "SPECIFIC_Data", "CONTAINS_Data"

End Sub

    Sub XLDataScan(strSourceFile As String, sSubID As String, sOrg As String)
        Dim RowPlace As Integer
        Dim strSQL As String
         Dim cn As Object, rs As Object, output As String, sql As String
       
        ' Start writing data to row:
        RowPlace = 1
    
        ' Exact match search:
        If sSubID <> "" Then
            sql = "Select [Pull Date],[Account Name],[Last Name],[First Name],[Subscriber ID] from [Add-On Pull$] Where [Subscriber ID] = " & sSubID
        End If
        ' Wildcard search:
        If sOrg <> "" Then
             sql = "Select [Pull Date],[Account Name],[Last Name],[First Name],[Subscriber ID] from [Add-On Pull$] Where [Account Name] LIKE '%" & sOrg & "%'"
        End If
    
    
        '---Connecting to the Data Source---
        Set cn = CreateObject("ADODB.Connection")
        With cn
            .Provider = "Microsoft.ACE.OLEDB.12.0"
            .ConnectionString = "Data Source=" & strSourceFile & ";" & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
            .Open
        End With
        
        Set rs = cn.Execute(sql)
    
        ' Get Header Fields:  
    '         For f = 0 To rs.Fields.Count - 1
    '            On Error Resume Next
    '           .Cells(r, c + f).Formula = rs.Fields(f).Name
    '                 Debug.Print rs.Fields(f).Name
    '            On Error GoTo 0
    '        Next f
            
            On Error Resume Next
            rs.MoveFirst
            On Error GoTo 0
            Do While Not rs.EOF
                 For f = 0 To rs.Fields.Count - 1
                    On Error Resume Next
     '               .Cells(r, c + f).Formula = rs.Fields(f).value
                           Debug.Print "R: " & RowPlace & ", " & "f: " & f & " -> " & rs.Fields(f).value
                    'Write found record to Sheet:
                    Cells(RowPlace, 2 + f).value = rs.Fields(f).value
                    On Error GoTo 0
                Next f
                rs.MoveNext
                RowPlace = RowPlace + 1
            Loop
        
        '---Clean up---
        rs.Close
        cn.Close
        Set cn = Nothing
        Set rs = Nothing  
    
    End Sub

VBA search closed workbook(s) for value?

3 Answers3

Linked