VBA 搜索已关闭的工作簿以获取价值？

Question

我正在尝试在文件夹（和子文件夹）中搜索所有 Excel 工作簿以获取值。

我的excel工作簿所在的文件夹结构是这样的：

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

然后在我的存档文件夹中有各种子文件夹，例如

+ 2017
- April
- May

+ 2016
- April
- May

工作簿的名称可能都不同，因此代码可能需要使用通配符 *.xlsm 之类的东西

这是我目前所拥有的：

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

每个工作簿中的范围应始终保持不变。

我正在尝试一些简单的事情，例如在找到值时显示一条消息。但目前，尽管工作簿中存在价值，但我没有得到任何结果/没有消息。

我在这一行得到一个对象需要错误：

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

请谁能告诉我哪里出错了？

编辑：

我可以将消息框更改为 for each loop 以列出每个结果，如下所示：

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

想要的结果

Answer 1

您的代码设置方式不起作用。您不能将Workbooks.Open() 方法与通配符一起使用，因为它一次只会打开一个文件并且不会搜索文件。有两种方法可以在目录中搜索具有我所知道的特定命名模式的文件。最简单的方法是使用Dir() 函数，但这不会很容易递归到子文件夹中。

第二种方式（下面为您编码）是一种使用FileSystemObject 递归遍历文件和子文件夹的方式。为了使用它，您需要将项目的引用添加到 Microsoft Scripting Runtime 库中。您可以通过 Tools->References 添加引用。

另请注意，此方法使用Range.Find() 方法在您的工作簿中查找客户名称，因为它应该比您当前查找客户名称是否在工作表中的方法更快、更容易理解。

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

Answer 2

如果不知道客户 ID，我需要浏览一份工作报告文件列表并搜索客户 ID 号或公司名称的通配符部分选择。

我清理了查询以删除大部分多余的不必要字段，然后停在那里。我还打算将 2 个不同的查询合并到 1 个程序语句中，但它与我抗争，我停在那里。

为临时查询放置制作一个名为“输出”的工作表。它只是复制数据结果而不是标题，因为我将多个结果串在一起。您当然需要记录宏和数据/获取数据/从文件/从工作簿，打开工作簿，转换数据，选择要返回的列，然后在列上输入搜索参数，然后关闭并返回到您的电子表格，最后停止宏以获取您自己的查询。

    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

Answer 3

我更新了我的代码以使用 ADO 来查询已关闭的工作簿。对于搜索的 50 个文件，这比我之前发布的代码快了大约 10 秒，完成时间是 40 秒，而完成时间大约是 50 秒。

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