vba 宏将不同工作簿中的数据合并到一个工作簿中

Question

我需要一个宏来收集来自 3 个不同工作簿的信息并将其合并到第 4 个工作簿的一个选项卡上。

对于每个文件，列数相同，但行数不同。我需要做的宏是从 3 个源文件中的第一个中获取数据 + 列标题并将它们粘贴到目标文件中。然后，对于每个后续源文件，我需要宏仅粘贴从紧随其后的行开始的数据（无列标题）。

另外，目标文件与源文件位于不同的文件夹中。我将来会添加新文件的另一件事是源文件的数量可能会更多。所以下面只是一些名字的例子，供人们帮助我编写代码，之后我可以进去修改细节。

以下是详细信息：

1) 每个源文件都有我需要在 A:I 列中复制的数据。 2) 在每个源文件中，列标题在第 1 行，数据从第 2 行开始。 3) 在每个源文件中，我需要复制的数据位于“子文件_NCANDS”选项卡中。 4) 3个源文件所在的文件夹标题为“Testing Macro” 5) 在目标文件中，数据将被复制并粘贴到“子文件_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

正如我在 cmets 中提到的，这假定目标工作表上的标题已经存在。当您只需将标题添加到目标工作表一次时，为其编码是没有意义的。

---

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