Question

我需要一个宏，它可以从3个不同的工作簿中收集信息，并将其合并到第4个工作簿的一个选项卡上。

对于每个文件，列数相同，但行数不同。我需要执行的宏操作是从3个源文件中的第一个获取数据+列标题并将其粘贴到目标文件中。然后，对于随后的每个源文件，我都需要宏以仅粘贴从紧挨着下面的行开始的数据（无列标题）。

目标文件也与源文件位于不同的文件夹中。将来我还要添加新文件，因此源文件的数量可能会更多。因此，下面仅是示例名称，以帮助人们使用代码，以后我可以进入并更改详细信息。

以下是详细信息：

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

vba宏可将来自不同工作簿的数据整合到一个工作簿中

1 个答案: