將多個工作簿中的表格合並到一個主工作簿中

Question

我是 VBA 的新手，正在嘗試合並來自多個工作簿的表格並創建一個大型主工作簿。 基本思想是（我到目前為止所做的）：

1. 我創建了一個名為“Master”的空白工作簿，工作表名稱為“total”，這是我要將提取的數據粘貼到的工作簿。 我在本工作簿中創建了 VBA。
2. 我有 100 多個源文件，我想從中提取一個表。 它們都在同一目錄中：“C:\Users\Documents\Test” 這些工作表被命名為“Sheet1”。
3. 要創建主工作簿，我想找到最后一行並開始從下一個電子表格復制新值，但我的代碼目前無法正常工作。
4. 另一個問題是來自不同工作簿的每個表都包含自己的 header（列名），我想跳過第二個文件的標題。
5. 這些表位於每個工作簿的 A1:N53 中。

這是我當前的代碼：

Private Sub Extraction()

Application.ScreenUpdating = False

Dim wkbDest As Workbook
Dim wkbSource As Workbook
Set wkbDest = ThisWorkbook
Dim LastRow As Long
Dim strExtension As String

Const strPath As String = "C:\Users\Documents\Test\"
strExtension = Dir(strPath & "*.xls*")

Do While strExtension <> ""
    Set wkbSource = Workbooks.Open(strExtension)
    With wkbSource
      LastRow = .Sheets("total").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      .Sheets("Sheet1").Range("A1:N3" & LastRow).Copy wkbDest.Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        .Close savechanges:=False
    End With
    strExtension = Dir
Loop
Application.ScreenUpdating = True

End Sub

我肯定搞砸了它定位數據的位置並將其復制並粘貼到主工作簿。 如果有人可以幫助我修改我的代碼行，我將不勝感激。

先感謝您。

Answer 1

對不起，我在旅途中寫了這個腳本，所以我沒有測試它。

它幾乎符合您的要求。 從主文件執行腳本。 它使用 DIR() 遍歷目錄內的所有文件並調用 Resize 子過程以獲取“A1:N53”范圍內的值並將其傳輸到主文件中。

DIR() 將遍歷文件路徑中的所有文件。 對於每個文件，它將獲取 sheets(1) range("A1:N53") 中的數據（如果您不想包含 header，則將其更改為 range("A2:N53")。抱歉，解釋有點含糊）

通過范圍獲取數據后，腳本將簡單地調整范圍大小並根據最后一行計數將值傳輸到 Sheets(master) 中。

請讓我知道它是否有效，但無效，請跟進評論並繼續努力！

謝謝，

腳本如下：

Option Explicit

Dim fpath As String
Dim fname As String

Dim wb As Workbook
Dim twb As Workbook

Dim rgSrc As Range
Dim rgDest As Range

Sub foo()
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False


  Set wb = ThisWorkbook

  fpath = "C:\Users\Documents\Test\"

  fname = Dir(fpath)


  Do While fname <> ""

      Set twb = Workbooks.Open(fpath & fname)

      Call Resize

      twb.Close
   
      fname = Dir()
    
  Loop

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True


End Sub


Private Sub Resize()


    ' Get all the data in the current region?change it to "A2:N53" is you dont want header included from the files in filepath
    Set rgSrc = twb.Sheets(1).Range("A1:N53")

    'Get the range destination
    Set rgDest = wb.Sheets("Master").Cells(wb.Sheets("Master").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)

    Set rgDest = rgDest.Resize(rgSrc.Rows.Count, rgSrc.Columns.Count)
    
    rgDest.Value2 = rgSrc.Value2


End Sub

Answer 2

您可以嘗試以下我已經使用了一段時間並且看起來工作正常的代碼。 提示框會要求您輸入 select 文件，並將所有文件合並到一個堆疊數據庫中。 它還將添加一個文件名，以便您可以識別從中選擇數據的文件名。 下面的代碼 - 讓我知道這是否有幫助 -

Private Declare PtrSafe Function SetCurrentDirectoryA Lib _
    "kernel32" (ByVal lpPathName As String) As Long

Sub ChDirNet(szPath As String)
    SetCurrentDirectoryA szPath
End Sub


Sub MergeSpecificWorkbooks()
    Dim MyPath As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim SaveDriveDir As String
    Dim FName As Variant
    Dim FirstCell As String



    ' Set application properties.
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    SaveDriveDir = CurDir
    ' Change this to the path\folder location of the files.
    ChDirNet "C:\Users\nik\test"

    FName = Application.GetOpenFilename(FileFilter:="Excel Files (*.xl*), *.xl*", _
                                        MultiSelect:=True)
    If IsArray(FName) Then

        ' Add a new workbook with one sheet.
        Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
        rnum = 1


        ' Loop through all files in the myFiles array.
        For FNum = LBound(FName) To UBound(FName)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(FName(FNum))
            On Error GoTo 0

            If Not mybook Is Nothing Then

                On Error Resume Next
                With mybook.Worksheets(1)
                   FirstCell = "A1"
                   Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
                   ' Test if the row of the last cell is equal to or greater than the row of the first cell.
                   If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
                      Set sourceRange = Nothing
                   End If
                End With



                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    ' If the source range uses all columns then
                    ' skip this file.
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "There are not enough rows in the target worksheet."
                        BaseWks.Columns.AutoFit
                        mybook.Close SaveChanges:=False
                        GoTo ExitTheSub
                    Else

                        ' Copy the file name in column A.
                        With sourceRange
                            BaseWks.Cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = FName(FNum)
                        End With

                        ' Set the destination range.
                        Set destrange = BaseWks.Range("B" & rnum)

                        ' Copy the values from the source range
                        ' to the destination range.
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value
                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close SaveChanges:=False
            End If

        Next FNum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    ' Restore the application properties.
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
    ChDirNet SaveDriveDir
End Sub



Function RDB_Last(choice As Integer, rng As Range)

' A choice of 1 = last row.
' A choice of 2 = last column.
' A choice of 3 = last cell.
   Dim lrw As Long
   Dim lcol As Integer

   Select Case choice

   Case 1:
      On Error Resume Next
      RDB_Last = rng.Find(What:="*", _
                          After:=rng.Cells(1), _
                          LookAt:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
      On Error GoTo 0

   Case 2:
      On Error Resume Next
      RDB_Last = rng.Find(What:="*", _
                          After:=rng.Cells(1), _
                          LookAt:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByColumns, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Column
      On Error GoTo 0

   Case 3:
      On Error Resume Next
      lrw = rng.Find(What:="*", _
                    After:=rng.Cells(1), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row
      On Error GoTo 0

      On Error Resume Next
      lcol = rng.Find(What:="*", _
                     After:=rng.Cells(1), _
                     LookAt:=xlPart, _
                     LookIn:=xlFormulas, _
                     SearchOrder:=xlByColumns, _
                     SearchDirection:=xlPrevious, _
                     MatchCase:=False).Column
      On Error GoTo 0

      On Error Resume Next
      RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
      If Err.Number > 0 Then
         RDB_Last = rng.Cells(1).Address(False, False)
         Err.Clear
      End If
      On Error GoTo 0

   End Select
End Function