從子文件夾excel文件中復制來自非連續單元格（A1，B5，C6）的數據並粘貼到父文件夾中找到的主文件中

Question

我有4個子文件夾包含.xlsm格式的excel文件，在父文件夾中我有一個主excel工作簿。 我的程序將從子文件夾中所有excel工作簿的sheet1中找到的常見非連續單元格（A1，B5，C6）中復制數據，並將其粘貼到主Excel工作簿表（“模板”）下面。循環遍歷文件夾，將一次打開一個格式為xlsm的excel文件。 然后將從第一個工作簿復制單元格A1，B5，C6並關閉它並將其粘貼到A2，B2和C2的主工作簿模板表中。然后它將打開下一個excel文件副本A1，B5，C6。關閉工作簿並在主工作簿的模板表中粘貼A3，B3，C3。 循環遍歷子文件夾中的所有excel文件后，此過程將繼續

'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

      lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

      lastcolumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column

      ActiveSheet.Range("A1,B5,C6").Copy
'Close opened workbook without saving any changes

     wbk.Close SaveChanges:=False

           erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

      ActiveSheet.Cells(erow, 1).Select

      ActiveSheet.Paste

     ActiveWorkbook.Save

     Application.CutCopyMode = False

       myFile = Dir
     Loop

     Next myItem

       Application.ScreenUpdating = True


    End Sub

Answer 1

這是它應該如何正常工作：

Option Explicit
Sub Test()

    Dim wb As Workbook 'add a reference for the master workbook
    Dim CopyCellA As Range
    Dim CopyCellB As Range
    Dim CopyCellC As Range
    Set wb = ThisWorkbook 'if the master workbook is the one having the code


    '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
            With wbk.Sheets(1) '1 is the first sheet on the book, change this if not
                'The next 2 lines are useless because you are not using lastrow or lastcolumn anywhere
                LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'you also need to reference the rows.count
                LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column 'same as above
                Set CopyCellA = .Range("A1")
                Set CopyCellB = .Range("B5")
                Set CopyCellC = .Range("C6")
            End With
            With wb.Sheets("MySheet") 'change MySheet for the sheet name where you are pasting
                erow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                .Cells(erow, 1) = CopyCellA 'no need to select
                .Cells(erow, 2) = CopyCellB
                .Cells(erow, 3) = CopyCellC
            End With

            'Close opened workbook without saving any changes
            wbk.Close SaveChanges:=False
            wb.Save
            Application.CutCopyMode = False

            myFile = Dir
        Loop
    Next myItem

    Application.ScreenUpdating = True

End Sub