將 excel 工作表從文件夾合並到一個工作表中

Question

我在一個文件夾中有 20 個 excel 文件。 我想將所有文件合並到一張紙上。 列的順序不同，因此首先它應該查找列 header，然后復制粘貼該列中的數據。 . 在每個 excel 中有多個工作表，但我只需要獲取並合並“PIPES”工作表。 我在互聯網上搜索並嘗試了 2-3 種方法，但我無法糾正它，任何人都可以幫助我使用這個或任何新代碼。

子測試（）

Dim FileFold As String
Dim FileSpec As String
Dim FileName As String
Dim ShtCnt As Long
Dim RowCnt As Long
Dim Merged As Workbook
Dim wb As Workbook
Dim ws As Worksheet
Dim Lastcol As Long
Dim i As Integer
Dim j As Integer

FileFold = "C:\Users\KK\Desktop\VR"

FileSpec = FileFold & Application.PathSeparator & "*.xlsx*"
FileName = Dir(FileSpec)

'Exit if no files found
If FileName = vbNullString Then
    MsgBox Prompt:="No files were found that match " & FileSpec, Buttons:=vbCritical, Title:="Error"
    Exit Sub
End If

With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
End With

ShtCnt = 0
RowCnt = 1

Set Merged = Workbooks.Add

Do While FileName <> vbNullString
    ShtCnt = ShtCnt + 1
    Set wb = Workbooks.Open(FileName:=FileFold & Application.PathSeparator & FileName, UpdateLinks:=False)
    Set ws = wb.Worksheets("PIPES")
    With ws
    LastColumn = ws.Cells.SpecialCells(xlCellTypeLastCell).Column
        If .FilterMode Then .ShowAllData
        If ws.Range(1, i).Value = Merged.Worksheets(1).Range(1, j) Then
        .Range("A2").CurrentRegion.Copy Destination:=Merged.Worksheets(1).Cells(RowCnt, 1)
        End If
       
    End With
    wb.Close SaveChanges:=False
    RowCnt = Application.WorksheetFunction.CountA(Merged.Worksheets(1).Columns("A:A")) + 1
    FileName = Dir
Loop

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

MsgBox Prompt:="Finished merging.", Buttons:=vbInformation, Title:="Success"

End Sub

Answer 1

未經測試但應該接近：

Sub Test()
    Const FILE_ROOT As String = "C:\Users\KK\Desktop\VR\" 'use const for fixed values
    
    Dim FileFold As String, FileSpec As String, FileName As String
    Dim NextRow As Long, LastRow As Long, ShtCnt As Long
    Dim Merged As Workbook, wsMerged As Worksheet
    Dim wb As Workbook, ws As Worksheet, c As Range
    Dim m As Variant, rngCopy As Range, nextHdr As Range
    
    FileSpec = FILE_ROOT & "*.xlsx"
    FileName = Dir(FileSpec)
    If FileName = vbNullString Then
        MsgBox Prompt:="No files were found that match " & FileSpec, _
               Buttons:=vbCritical, Title:="Error"
        Exit Sub
    End If
    
    GoFast
    Set Merged = Workbooks.Add
    Set wsMerged = Merged.Worksheets(1)
    
    Do While FileName <> vbNullString
        ShtCnt = ShtCnt + 1
        Set wb = Workbooks.Open(FileName:=FILE_ROOT & FileName, ReadOnly:=True, UpdateLinks:=False)
        Set ws = wb.Worksheets("PIPES")
        With ws
            If .FilterMode Then .ShowAllData
            If ShtCnt = 1 Then
                Set rngCopy = .Range("A1").CurrentRegion
                rngCopy.Copy wsMerged.Range("A1")
                NextRow = rngCopy.Rows.Count + 1 'next paste row
            Else
                LastRow = .Cells.Find(what:="*", After:=.Range("A1"), LookAt:=xlPart, _
                                      LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                                      SearchDirection:=xlPrevious).row
                'loop over the headers in row 1
                For Each c In .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft)).Cells
                    'try to match a header on the "merged" sheet
                    m = Application.Match(c.Value, wsMerged.Rows(1), 0)
                    If IsError(m) Then 'if no match, add as a new header
                        Set nextHdr = wsMerged.Cells(1, .Columns.Count).End(xlToLeft).Offset(0, 1)
                        nextHdr.Value = c.Value
                        m = nextHdr.Column 'new column position
                    End If
                    Set rngCopy = ws.Range(c.Offset(1), ws.Cells(LastRow, c.Column))
                    rngCopy.Copy wsMerged.Cells(NextRow, m)
                Next c
                NextRow = NextRow + (LastRow - 1)  'next paste row
            End If
        End With
        wb.Close SaveChanges:=False
        FileName = Dir
    Loop
    
    GoFast False
    MsgBox Prompt:="Finished merging.", Buttons:=vbInformation, Title:="Success"

End Sub

'maximize code speed by turning off unneeded stuff
'******** must reset !!!!
Sub GoFast(Optional SpeedUp As Boolean = True)
  With Application
      .ScreenUpdating = Not SpeedUp
      .Calculation = IIf(SpeedUp, xlCalculationManual, xlCalculationAutomatic)
  End With
End Sub