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

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.

我需要我的代码做的是允许用户点击命令按钮，然后用户选择一个文件夹。一旦选择此文件夹。我需要的代码或遍历这个文件夹,该文件夹中的所有子文件夹,找到表与一个名称(如“CustomerExp”然后复制的数据表名称如“CustomerExp”从第二行到最后一行和使用的信息粘贴到一张名为“纠纷”宏在哪里住。

I have supplied pictures for better understanding.

我为更好的理解提供了图片。

Pic 1 is where the macro is housed and where i need the info pasted to.

图1是宏所在的位置，我需要将信息粘贴到这里。

Pic 1

图片1

Pic 2 is the first file the user will select and the only one i want them to select

图2是用户将选择的第一个文件，也是我希望用户选择的唯一文件

Pic 2

图片2

Pic 3 you can see that in folder 2017 there are several other folders

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

Pic 3

图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

图4同样，你可以看到我们有我正在寻找的文件，以及更多需要循环的文件夹

Pic 4

图片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.

基本上我需要的代码要做的就是让2017人选择文件夹,然后单击ok代码经过2017文件夹找到了文件名称中的一切“CustomerExp”副本数据和贴的“纠纷”的冰盖宏举行。

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

1 个解决方案

#1

Just couple of minor issues in your code:

你的代码中有几个小问题:

1. With wb.Sheets(1) should be With wbk.Sheets(1)

1。与wb.Sheets(1)应该与wbk.Sheets(1)

followed by

紧随其后的是

lRow = .Range("A" & Rows.Count).End(xlUp).Row should be lRow = .Range("A" & .Rows.Count).End(xlUp).Row

lRow = . range(“A”& row . count). end (xlUp)。行应该是lRow = .Range(“A”& .Row . count).End(xlUp).Row

as already pointed out by @ShaiRado in comments

@ShaiRado在评论中已经指出

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 & "\")

2。myFile = Dir(MyFolder & ChildFolder.Name)应该是myFile = Dir(MyFolder & ChildFolder.)。名字和“\”)

#1