Макрос vba для объединения данных из разных книг в одну книгу

Question

Мне нужен макрос, который собирает информацию из 3 различных рабочих книг и объединяет ее на одной вкладке в 4-й рабочей книге.

Для каждого файла количество столбцов одинаковое, но количество строк различается.Что мне нужно сделать для макроса, так это взять заголовки столбца data + из первого из 3 исходных файлов и вставить их в конечный файл.Затем для каждого последующего исходного файла мне нужен макрос для вставки только данных (без заголовков столбцов), начиная с строки, расположенной сразу ниже.

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

Вот подробности:

1) Каждый исходный файл имеетданные, которые мне нужно скопировать в столбцах A: I.2) В каждом исходном файле заголовки столбцов находятся в строке 1, а данные начинаются со строки 2. 3) В каждом исходном файле данные, которые мне нужно скопировать, находятся на вкладке «Child File_NCANDS».4) Папка, в которой находятся 3 исходных файла, называется «Тестирование макроса». 5) В целевом файле данные будут скопированы и вставлены на вкладку «Child File_NCANDS».6) Файл назначения называется «TA Call Notes_Compiled_TEST.xls»

Вот код, который я создал до сих пор:

Sub TA_Call_Notes_Compiled()
' ---------------------------------------------------------------------------------------------
  Dim i As Long, lCurrRow As Long, lRow As Long, n As Long
  Dim wb As Workbook, ans As VbMsgBoxResult

  For i = 1 To 3 Step 1

' -----------------------------------------------------------------------------------------
' Open up Source Workbook
' -----------------------------------------------------------------------------------------
On Error Resume Next
Set wb = Workbooks.Open(ThisWorkbook.Path & "N:\2012-2015 contract\State Data Submission_Validation_Communication\Technical Assistance\TA Calls 2018\Testing Macro" & i & ".xlsx")
If Not Err.Number = 0 Then
  Err.Clear

  ' ---------------------------------------------------------------------------------------
  ' Source Workbook was not found using SourceX.xls format, try Source X.xls format
  ' ---------------------------------------------------------------------------------------
  Set wb = Workbooks.Open(ThisWorkbook.Path & "N:\2012-2015 contract\State Data Submission_Validation_Communication\Technical Assistance\TA Calls 2018\Testing Macro" & i & ".xls")
  If Not Err.Number = 0 Then
    Err.Clear

    ' -------------------------------------------------------------------------------------
    ' No source workbook found, advise user.
    ' -------------------------------------------------------------------------------------
    ans = MsgBox("Could not find Source " & i & " Workbook." & vbNewLine & "Do you wis" & _
                 "h to continue?", vbInformation + vbYesNo, "Error")
    If ans = vbNo Then Exit Sub
    GoTo NextI
  End If
End If

' -----------------------------------------------------------------------------------------
' Source book was found, data to use is on Data Output.
' -----------------------------------------------------------------------------------------
With wb.Sheets("Child File_NCANDS")
  If Not Err.Number = 0 Then
    Err.Clear

    ' -------------------------------------------------------------------------------------
    ' No Data Output tab found, advise user.
    ' -------------------------------------------------------------------------------------
    ans = MsgBox("Could not find Source " & i & " Workbook's 'Data Output' tab." & _
                 vbNewLine & "Do you wish to continue?", vbInformation + vbYesNo, "Error")
    If ans = vbNo Then
      wb.Close False
      Exit Sub
    End If
    GoTo NextI
  End If

  ' ---------------------------------------------------------------------------------------
  ' Ensure we add headers.
  ' ---------------------------------------------------------------------------------------
  If i = 1 Then
    lRow = 1
  Else
    lRow = 2
  End If

  ' ---------------------------------------------------------------------------------------
  ' We are assuming the value in column A will be filled and there is no breaks until the
  ' end of our entries.  If this is not the case additional code will be needed to
  ' determine the end of our entries.
  ' ---------------------------------------------------------------------------------------
  Do Until .Range("A:I" & lRow).Value = vbNullString
    lCurrRow = lCurrRow + 1
    For n = 0 To 3 Step 1
      Sheets("Child File_NCANDS").Range("A:I" & lCurrRow).Offset(ColumnOffset:=n).Value = .Range("A:I" & lRow).Offset(ColumnOffset:=n).Value
    Next n
    lRow = lRow + 1
  Loop
End With
NextI:
wb.Close False
Next i
Set wb = Nothing
End Sub

Answer 1

Как я уже упоминал в комментариях, предполагается, что заголовок на листе назначения уже существует.Кодировать его не имеет смысла, когда вы только один раз добавляете заголовок к листу назначения.

---

Option Explicit

Sub Consolidate()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Child File_NCANDS")
Dim IndvFiles As FileDialog
Dim Currentbook As Workbook
Dim i As Integer, LRow As Long, wbLRow As Long
Dim Import As Range

'Opens File Dialog to Select Which Files You Want to Consolidate
Set IndvFiles = Application.FileDialog(msoFileDialogOpen)
With IndvFiles
    .AllowMultiSelect = True
    .Title = "Multi-select target data files:"
    .ButtonName = ""
    .Filters.Clear
    .Show
End With

If IndvFiles.SelectedItems.Count = 0 Then Exit Sub 'If no files are selected, Exit Sub

Application.ScreenUpdating = False
Application.DisplayAlerts = False
    For i = 1 To IndvFiles.SelectedItems.Count 'Loop for selected files
        Set Currentbook = Workbooks.Open(IndvFiles.SelectedItems(i))
            With Currentbook.Sheets("Child File_NCANDS")
                LRow = .Range("A" & .Rows.Count).End(xlUp).Row 'Last Row of Import Sheet
                wbLRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1).Row 'Last Row of Destination Sheet
                    Set Import = .Range("A2:I" & LRow)
                    Import.Copy
                    ws.Range("A" & wbLRow).PasteSpecial Paste:=xlPasteValues
            End With
        Currentbook.Close False
    Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub