copy data from non contiguous cells (A1, B5, C6) from subfolders excel files and paste in master file found in parent folder

Question

I got 4 subfolders containing excel files in .xlsm format and in the parent folder I got a master excel workbook. My program will copy data from common non-contiguous cells (A1, B5, C6) found in sheet1 of all the excel workbook in subfolders and paste it in the master excel workbook sheet (“template”) Below there is extract of code that will loop through the folders and will open one excel file in format of xlsm one at a time. Then will copy the cell A1, B5, C6 from first workbook and close it and paste it in the master workbook template sheet at A2, B2 and C2.Then it will open the next excel file copy A1, B5, C6.close the workbook and paste at A3,B3,C3 in template sheet of master workbook. This process will continue after having loop through all the excel files in subfolders

'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

This is how it should work properly:

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