VBA搜索关闭工作簿的价值？
我正在尝试在文件夹（和子文件夹）中搜索所有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
请有人告诉我我哪里出错了吗？
编辑：
我可以将消息框更改为a，以便为每个循环列出每个结果，如下所示：
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
期望的结果
3 个答案:
答案 0 :(得分：2)
您的代码设置方式无效。您不能将Workbooks.Open()方法与通配符一起使用，因为它一次只能打开一个文件而不会搜索文件。有两种方法可以在目录中搜索具有我所知的特定命名模式的文件。最简单的方法是使用Dir()函数，但这不会很容易地递归到子文件夹中。
第二种方式（在下面编码）是一种通过使用FileSystemObject的文件和子文件夹进行递归的方法。为了使用它，您需要将项目的引用添加到 Microsoft Scripting Runtime 库。您可以通过工具 - >参考文献添加参考。
另请注意，此方法使用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
答案 1 :(得分：0)
如果不知道客户 ID，我需要查看工作报告文件列表并搜索客户 ID 号或公司名称的通配符部分选择。
我清理了 Query 以删除大部分多余的不必要的字段，然后停在那里。我还打算将 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
答案 2 :(得分：0)
我更新了代码以使用 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
相关问题
最新问题
- 我写了这段代码，但我无法理解我的错误
- 我无法从一个代码实例的列表中删除 None 值，但我可以在另一个实例中。为什么它适用于一个细分市场而不适用于另一个细分市场？
- 是否有可能使 loadstring 不可能等于打印？卢阿
- java中的random.expovariate()
- Appscript 通过会议在 Google 日历中发送电子邮件和创建活动
- 为什么我的 Onclick 箭头功能在 React 中不起作用？
- 在此代码中是否有使用“this”的替代方法？
- 在 SQL Server 和 PostgreSQL 上查询，我如何从第一个表获得第二个表的可视化
- 每千个数字得到
- 更新了城市边界 KML 文件的来源？