VBA通过文件夹和子文件夹循环查找特定工作表，然后复制并粘贴特定数据

我希望你能帮上忙。 我试图自己编写代码（见下面的代码），但是失败了，所以我正在向社区寻求帮助。

我需要的代码是让用户点击一个命令button，然后用户select一个文件夹。 一旦这个文件夹被选中。 我需要代码来查看或循环通过此文件夹和此文件夹中的所有子文件夹，并find具有名称的工作表像“ CustomerExp ”，然后复制工作表名称中的数据像“ CustomerExp ”从第二行到最后一个使用的行并将信息粘贴到名为“Disputes”的表单中，该表格中放置了macros。

我提供了更好的理解照片。

图1是macros的地方，我需要粘贴的信息。

图1

图2是用户将要select的第一个文件，也是我希望他们select的唯一文件

图2

图3你可以看到，在文件夹2017有几个其他的文件夹

图3

图4再次，你可以看到我们有我正在寻找的文件加上更多的文件夹，需要循环

图4

本质上，我需要的代码是让人select2017年文件夹单击确定，然后代码遍历2017年文件夹中的所有内容查找名称的文件像“ CustomerExp ”复制数据和粘贴到表“争议”表macros在哪里举行。

我的代码编译，但没有做任何事情。 与往常一样，所有的帮助，不胜感激。

我的代码

Sub AllWorkbooks() Dim MyFolder As String 'Path collected from the folder picker dialog Dim myFile As String 'Filename obtained by DIR function Dim wbk As Workbook 'Used to loop through each workbook Dim FSO As New FileSystemObject ' Requires "Windows Script Host Object Model" in Tools -> References Dim ParentFolder As Object, ChildFolder As Object Dim wb As Workbook Dim myPath As String Dim myExtension As String Dim FldrPicker As FileDialog Dim lRow As Long Dim ws2 As Worksheet Dim y As Workbook On Error Resume Next Application.ScreenUpdating = False 'Opens the folder picker dialog to allow user selection With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Please select a folder" .Show .AllowMultiSelect = False If .SelectedItems.Count = 0 Then 'If no folder is selected, abort MsgBox "You did not select a folder" Exit Sub End If MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder End With myFile = Dir(MyFolder) 'DIR gets the first file of the folder Set y = ThisWorkbook Set ws2 = y.Sheets("Disputes") 'Loop through all files in a folder until DIR cannot find anymore Do While myFile <> "" If myFile Like "*CustomerExp*" Then 'Opens the file and assigns to the wbk variable for future use Set wbk = Workbooks.Open(Filename:=MyFolder & myFile) 'Replace the line below with the statements you would want your macro to perform With wb.Sheets(1) lRow = .Range("A" & Rows.Count).End(xlUp).Row .Range("A2:M" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp)(2) End With Application.Wait (Now + TimeValue("0:00:05")) wbk.Close savechanges:=True End If myFile = Dir 'DIR gets the next file in the folder Loop For Each ChildFolder In FSO.GetFolder(MyFolder).SubFolders myFile = Dir(MyFolder & ChildFolder.Name) 'DIR gets the first file of the folder 'Loop through all files in a folder until DIR cannot find anymore Do While myFile <> "" If myFile Like "*CustomerExp*" Then 'Opens the file and assigns to the wbk variable for future use Set wbk = Workbooks.Open(Filename:=MyFolder & ChildFolder.Name & "\" & myFile) 'Replace the line below with the statements you would want your macro to perform With wb.Sheets(1) lRow = .Range("A" & Rows.Count).End(xlUp).Row .Range("A2:M" & lRow).Copy ws2.Range("A" & Rows.Count).End(xlUp)(2) End With Application.Wait (Now + TimeValue("0:00:05")) wbk.Close savechanges:=True End If myFile = Dir 'DIR gets the next file in the folder Loop Next ChildFolder Application.ScreenUpdating = True End Sub 

Answer 1

只是你的代码中的一些小问题：

1. With wb.Sheets(1)应该With wbk.Sheets(1)

其次是

lRow = .Range("A" & Rows.Count).End(xlUp).Row应该是lRow = .Range("A" & .Rows.Count).End(xlUp).Row

正如@ShaiRado在评论中指出的那样

你必须在两个地方做出上述改变。 首先在

 Do While myFile <> "" Loop 

然后在每个循环内再循环

 For Each ChildFolder In FSO.GetFolder(MyFolder).SubFolders Do While myFile <> "" Loop Next ChildFolder 

2. myFile = Dir(MyFolder & ChildFolder.Name)应该是myFile = Dir(MyFolder & ChildFolder.Name & "\")