将文件夹中的Excel工作表合并到单个工作表中

我在一个文件夹中有20个Excel文件。我想将所有文件中的一个工作表合并为一个工作表。

列的顺序不相同，因此首先应查找列标题，然后复制粘贴该列中的数据。

在每个文件有多个工作表。我需要合并只有“管道”工作表。

Sub Test()

    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

编辑：测试和为我工作（做了几个修复）-

Sub Test()
    Const FILE_ROOT As String = "C:\Users\KK\Desktop\VR\" 'use const for fixed values
    
    Dim allFiles As Collection, xlFile
    Dim NextRow As Long, LastRow As Long, ShtCnt As Long
    Dim wb As Workbook, wsMerged As Worksheet, ws As Worksheet, c As Range, rngCopy As Range
    Dim dict As Object, NextColNum As Long, colNum As Long, hdr
    
    Set allFiles = FileMatches(FILE_ROOT, "*.xlsx") 'get all Excel files
    If allFiles.Count = 0 Then Exit Sub             'exit if no files to process
    
    Set dict = CreateObject("scripting.dictionary")
    dict.CompareMode = 1 'vbTextcompare; case-insensitive matching
    
    GoFast
    NextColNum = 0
    NextRow = 2
    Set wsMerged = Workbooks.Add.Worksheets(1)
    
    For Each xlFile In allFiles
        ShtCnt = ShtCnt + 1
        Set wb = Workbooks.Open(Filename:=xlFile, ReadOnly:=True, UpdateLinks:=False)
        Set ws = wb.Worksheets("PIPES")
        With ws
            If .FilterMode Then .ShowAllData
            LastRow = RangeLastRow(.Cells)   'last occupied row on the source sheet
            If LastRow > 1 Then              'any data to copy?
                'loop all headers in source worksheet
                For Each c In .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft)).Cells
                    hdr = Trim(c.Value)
                    If Len(hdr) > 0 Then
                        If Not dict.Exists(c.Value) Then 'does this header already exist on "merged" sheet?
                            NextColNum = NextColNum + 1            'next header position
                            dict.Add hdr, NextColNum               'add to dictionary
                            wsMerged.Cells(1, NextColNum).Value = hdr  'add the new header
                            Debug.Print "Added header", hdr, NextColNum, wb.Name
                        End If
                        c.Offset(1).Resize(LastRow - 1).Copy wsMerged.Cells(NextRow, dict(hdr))
                    End If 'have a header
                Next c
                NextRow = NextRow + (LastRow - 1)  'next paste row
            End If                                 'have any data to copy
        End With
        wb.Close SaveChanges:=False
    Next xlFile
    
    GoFast False 'remove speed optimizations
    MsgBox Prompt:="Finished merging.", Buttons:=vbInformation, Title:="Success"
End Sub

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

'find the last used row in a range
Function RangeLastRow(rng As Range) As Long
    Dim f As Range
    Set f = rng.Find(what:="*", After:=rng.Cells(1), LookAt:=xlPart, _
            LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    If Not f Is Nothing Then RangeLastRow = f.row 'otherwise 0
End Function

'Get all matching files from supplied folder `root`
'  Pass False to `WarnNoMatches` to suppress message if no files found (default is True)
Function FileMatches(root As String, pattern As String, _
                     Optional WarnNoMatches As Boolean = True) As Collection
    Dim f, spec
    Set FileMatches = New Collection
    If Right(root, 1) <> "\" Then root = root & "\"
    spec = root & pattern
    f = Dir(spec)
    Do While Len(f) > 0
        FileMatches.Add root & f
        f = Dir()
    Loop
    If FileMatches.Count = 0 And WarnNoMatches Then
        MsgBox Prompt:="No files were found that match " & spec, _
               Buttons:=vbExclamation, Title:="No files found"
    End If
End Function

将文件夹中的Excel工作表合并到单个工作表中

1条答案

相关问题

热门标签

最新问答