如何遍历子文件夹并复制相同的不连续单元格数据并粘贴到主工作簿表中

Question

我有4个子文件夹，其中包含.xlsm格式的excel文件。我需要从子文件夹中的所有excel文件中复制相同非连续单元格（A2，C4，D15，E17）中的数据。我有一个父文件夹，其中存储我的主工作簿，名为PercentageABS.xlsm。我需要将数据粘贴到PercentageABS.xlsm wbk的名为“模板”的工作表中。

HEADER1 HEADER2 HEADER3 HEADER4 
CELL A2 CELL C4 CELL D15    CELL E17    SUBFOLDER1 EXCEL FILE 1

CELL A2 CELL C4 CELL D15    CELL E17    SUBFOLDER1 EXCEL FILE 2

CELL A2 CELL C4 CELL D15    CELL E17    SUBFOLDER2 EXCEL FILE 1

CELL A2 CELL C4 CELL D15    CELL E17    SUBFOLDER2 EXCEL FILE 2

CELL A2 CELL C4 CELL D15    CELL E17    SUBFOLDER3 EXCEL FILE 1

CELL A2 CELL C4 CELL D15    CELL E17    SUBFOLDER3 EXCEL FILE 2

CELL A2 CELL C4 CELL D15    CELL E17    SUBFOLDER4 EXCEL FILE 1

CELL A2 CELL C4 CELL D15    CELL E17    SUBFOLDER4 EXCEL FILE 2




  myFolder = "C:\Users\sunvi\Desktop\percentage\FEB 18\"

 'Retrieve first sub-folder

   mySubFolder = Dir(myFolder & “ * ”, vbDirectory)

    Application.ScreenUpdating = False


 Do While mySubFolder <> ""

     Select Case mySubFolder

     Case ".", ".."

 'ignore current folder or parent folder

     Case Else

 'Add to collection called collSubFolders

     collSubFolders.Add Item:=mySubFolder

     End Select

'Get next entry

     mySubFolder = Dir

 Loop

    'Loop through the collection

 For Each myItem In collSubFolders

    'Loop through Excel workbooks in subfolder

     myFile = Dir(myFolder & myItem & "\*.xlsm * ")



   Do While myFile <> ""

    'Open workbook

    Set wbk = Workbooks.Open(Filename:=myFolder & myItem & " \ " & myFile)


    'Copy data from the opened workbook


    Set pasteRange = MasterWrkBk.Sheets("Template").Range("A2")

        For X = 1 To 40

                For Each cel In .Range("A2, C4, D15, E17")

                    pasteRange.Offset(X - 1, Y).Value = cel.Value

             Y = Y + 1

            Next cel

             Y = 0
        Next 

    Application.CutCopyMode = False

    myFile = Dir
   Loop

 Next myItem

     Application.ScreenUpdating = True

 End Sub