скопировать данные из несмежных ячеек (A1, B5, C6) из подпапок Excel и вставить их в основной файл, найденный в родительской папке

Question

У меня есть 4 подпапки, содержащие файлы Excel в формате .xlsm, а в родительской папке - мастер-книгу Excel. Моя программа скопирует данные из общих несмежных ячеек (A1, B5, C6), находящихся на листе 1 всей книги Excel в подпапках, и вставит их в лист основной книги Excel («шаблон») Ниже приведен фрагмент кода, который будет проходить по папкам и открывать один файл Excel в формате xlsm по одному. Затем скопируйте ячейку 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