VBA Excel - открыть и скопировать из нескольких рабочих книг в один сводный лист (вставить в последовательный файл)

Question

Мне нужно открыть и скопировать информацию из нескольких рабочих книг и из одних и тех же ячеек с одинаковым именем листа на один сводный лист. Я использую следующий код VBA, который работает, но он вставляет все в том же формате (в результате чего информация только в одном формате из последней открытой книги). Мне нужно, чтобы макрос вставлялся каждый раз, когда он запускает цикл в следующем формате. Как я могу это сделать?

Вот код, который у меня есть:

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
    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

    'Loop through all files in a folder until DIR cannot find anymore
    Do While MyFile <> “”
       '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


    Range("B3").Select
    Selection.Copy
    Windows("Forecast.xlsm").Activate
    Cells(3, 1).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

        wbk.Activate
    Range("C11:J11").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Forecast.xlsm").Activate
    Cells(3, 4).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

        wbk.Close savechanges:=False

       MyFile = Dir 'DIR gets the next file in the folder
    Loop

    Application.ScreenUpdating = True

    End Sub

Answer 1

Подпрогноз () Dim MyFolder As String 'Путь, собранный из диалогового окна выбора папки Dim MyFile As String 'Имя файла, полученное функцией DIR Dim wbk As Workbook 'Используется для циклического просмотра каждой книги Дим я как целое В случае ошибки Продолжить Далее

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

'Loop through all files in a folder until DIR cannot find anymore
Do While MyFile <> “”
   '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

wbk.Worksheets("Dashboard ctc").Range("B3").Copy
Workbooks("Forecast.xlsm").Worksheets(1).Range("A" & Chr(Asc("3") + i)).PasteSpecial Paste:=xlPasteValues

wbk.Worksheets("Dashboard ctc").Range("B11:J11").Copy
Workbooks("Forecast.xlsm").Worksheets(1).Range("D" & Chr(Asc("3") + i)).PasteSpecial Paste:=xlPasteValues

i = i + 1


wbk.Close savechanges:=False

   MyFile = Dir 'DIR gets the next file in the folder
Loop

Application.ScreenUpdating = True

End Sub

Answer 2

Насколько я понимаю, вы просто хотите скопировать значения из некоторых диапазонов в разных файлах в последующие строки в другом файле.

Чтобы скопировать диапазон ячеек в VBA, вам не нужно выбирать их. Лучше использовать метод Range.Copy.

В вашем случае вы, вероятно, захотите сделать что-то вроде:

wbk.Worksheets(1).Range("C11:J11").Copy _
    destination:=ThisWorkbook.Worksheets(1).Range("D4")

Кстати: Cells(3, 1).Offset(1, 0) совпадает с: Cells(4,1).

Чтобы вставить каждый раз в следующий ряд, вы можете просто посчитать их. За пределами цикла while объявите переменную. Например: Dim i as Integer. Затем в каждой итерации увеличиваем его: i = i + 1. Тогда вы можете скопировать так:

wbk.Worksheets(1).Range("C11:J11").Copy _
    destination:=ThisWorkbook.Worksheets(1).Range( Chr(Asc("D")+i) & ":4")