VBA 搜索已关闭的工作簿以获取价值？
Posted
技术标签:
【中文标题】VBA 搜索已关闭的工作簿以获取价值？【英文标题】：VBA search closed workbook(s) for value? 【发布时间】：2017-04-20 09:06:54 【问题描述】：我正在尝试在文件夹（和子文件夹）中搜索所有 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
想要的结果
【问题讨论】：
在顶部写Option Explicit，然后尝试调试它。你必须定义 CloseIt 和 c 可能还有别的东西。 ***.com/questions/1139321/…
将所有位置收集在一个字符串中并在最后打印它们可能会更好，或者您是否希望每次都停下来并在找到值后做一些事情？如果这是您需要的功能，则很难停止中间代码并更新工作表。
@tompreston 在功能方面我只想显示一条消息，给出工作簿的名称和文件路径以及其中的值
【参考方案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
【讨论】：
感谢您，效果很好。但是有没有办法我可以更改消息框以列出每个结果？请参阅有问题的编辑 您想在单个工作表/工作簿中查找多个myClient 实例的位置吗？或者只是工作簿中myClient 的第一个实例，但在宏工作表中列出每个找到的工作簿？
请查看在编辑中上传的图片。我想列出每个找到的值以及每个找到的值出现的行、工作簿路径和名称【参考方案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
【讨论】：
【参考方案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
【讨论】：
以上是关于VBA 搜索已关闭的工作簿以获取价值？的主要内容，如果未能解决你的问题，请参考以下文章