VBA循环通过文件夹和子文件夹查找特定的工作表，然后复制并粘贴某些数据 [英] VBA Loop through folder and subfolders to find specific sheet then Copy and Paste certain data
问题描述
我需要我的代码要做的是允许用户点击命令按钮，然后用户选择一个文件夹。选择此文件夹后。我需要代码来查看或循环遍历此文件夹和此文件夹中的所有子文件夹，并查找名称为的表格，如 CustomerExp ，然后复制工作表名称中的数据像第二行直到最后一行使用的 CustomerExp ，并将信息粘贴到放置宏的名为争议的表格中。
我提供了图片，以便更好地了解。
Pic 1是宏的位置，我需要粘贴的信息。
Pic 1
图3您可以看到，在文件夹2017中还有其他几个文件夹
Pic 3
Pic 4再次，你可以看到我们有文件我正在寻找加上需要循环的更多文件夹
Pic 4
本质上，我需要的代码是允许该人员选择2017个文件夹，单击确定，然后代码将通过2017文件夹中的所有内容找到具有名称的文件 CustomerExp 将数据和粘贴复制到保存宏的工作表中的表格争议。
我的代码编译，但没有做任何事情。一如既往，任何和所有的帮助是非常感谢。
我的代码
Sub AllWorkbooks（）
Dim MyFolder As String'从文件夹选择器对话框收集的路径
Dim myFile As String'由DIR函数获取的文件名
Dim wbk As Workbook用于循环遍历每个工作簿
Dim FSO作为新的FileSystemObject'需要Windows脚本宿主对象模型在工具 - >引用
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
'打开文件夹选择器对话框以允许用户选择
With Application.FileDialog（msoFileDialogFolderPicker）
.Title =请选择一个文件夹
.Show
.AllowMultiSelect = False
如果.SelectedItems.Count = 0然后'如果没有选择文件夹，中止
MsgBox您没有选择一个文件夹
Exit Sub
End If
MyFolder = .SelectedItems（1）& \将所选文件夹分配给MyFolder
End with
myFile = Dir（MyFolder）'DIR获取文件夹的第一个文件
Set y = ThisWorkbook
设置ws2 = y.Sheets（争议）
'循环一个文件夹中的所有文件，直到DIR找不到
Do While myFile<>
如果myFile像* CustomerExp *然后
'打开文件并分配给wbk变量以备将来使用
设置wbk = Workbooks.Open（文件名：= MyFolder& myFile）
'将下面的行替换为您希望宏执行
的语句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）
结束
Application.Wait（Now + TimeValue（0:00:05））
wbk.Close savechanges：= True
End If
myFile = Dir'DIR获取文件夹中的下一个文件
循环
对于FSO.GetFolder（MyFolder）中的每个ChildFolder .SubFolders
myFile = Dir（MyFolder& ChildFolder .Name）'DIR获取第一个文件文件夹
'循环浏览文件夹中的所有文件，直到DIR找不到
Do While myFile<>
如果myFile像* CustomerExp *然后
'打开文件并分配给wbk变量以备将来使用
设置wbk = Workbooks.Open（文件名：= MyFolder& ChildFolder.Name&\& myFile）
'将下面的行替换为您希望宏执行
的语句with wb.Sheets（1）
lRow = .Range（A& Rows.Count）.End（xlUp）.Row
.Range（A2：M& lRow）.Copy ws2.Range（A& Rows。计数）.End（xlUp）（2）
结束
Application.Wait（Now + TimeValue（0:00:05））
wbk.Close savechanges： = True
如果
myFile = Dir'DIR获取文件夹中的下一个文件
Loop
Next ChildFolder
Application.ScreenUpdating = True
End Sub
你的公司的小问题de：
1。 用wb.Sheets（1）应该是code> with wbk.Sheets（1）
后跟
lRow = .Range（A& Rows.Count）.End（xlUp）.Row 应为 lRow = .Range（A& .Rows.Count）.End（xlUp）.Row
由@ShaiRado在评论中指出
您必须在两个地方进行上述更改。首先在
Do While myFile<>
循环
然后再次做在每个循环中循环
对于FSO.GetFolder（MyFolder）中的每个ChildFolder .SubFolders
而myFile<>
循环
下一个ChildFolder
$ b $ c $ c $ myFile = Dir（MyFolder& & ChildFolder.Name&\）
I hope you can help. I have made an attempt to code this myself (see code below) but failed so I am reaching out to the community for assistance.
What I need my code to do is allow a user to click on a command button, then the user selects a folder. Once this folder is selected. I need the code to look or loop through this folder and all the subfolders in this folder and find sheets with a name Like "CustomerExp" then copy the the data in sheets name Like "CustomerExp" from the second row down to the last used row and paste the information into a sheet called "Disputes" where the macro is housed.
I have supplied pictures for better understanding.
Pic 1 is where the macro is housed and where i need the info pasted to.
Pic 1
Pic 2 is the first file the user will select and the only one i want them to select
Pic 2
Pic 3 you can see that in folder 2017 there are several other folders
Pic 3
Pic 4 Again you can see that we have the file I am looking for plus more folders that need to be looped through
Pic 4
Essentially what I need the code to do is allow the person to select 2017 folder click ok and then the code goes through everything in the 2017 folder finds the files with names Like "CustomerExp" copies data and pastes to the sheet "Disputes" in the sheet where the macro is held.
My code compiles but its not doing anything. As always any and all help is greatly appreciated.
MY CODE
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
Just couple of minor issues in your code:
1. With wb.Sheets(1) should be With wbk.Sheets(1)
followed by
lRow = .Range("A" & Rows.Count).End(xlUp).Row should be lRow = .Range("A" & .Rows.Count).End(xlUp).Row
as already pointed out by @ShaiRado in comments
You have to make above changes at two places. First in
Do While myFile <> ""
Loop
and then again in do while loop inside for each loop
For Each ChildFolder In FSO.GetFolder(MyFolder).SubFolders
Do While myFile <> ""
Loop
Next ChildFolder
2. myFile = Dir(MyFolder & ChildFolder.Name) should be myFile = Dir(MyFolder & ChildFolder.Name & "\")
这篇关于VBA循环通过文件夹和子文件夹查找特定的工作表，然后复制并粘贴某些数据的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
