VBA遍历 Excel 合并到一个 Excel 文件

适用于将多个相同结构的 Excel 文件的数据，合并成一个 Excel。

Sub FileOpen()
    Dim File As String
    Dim sourceWorkbook As Workbook
    Dim strPath As String, strFileName As String
    Dim targetSheet As Worksheet
    Dim targetWorkbook As Workbook
    Dim currTime As Variant
    Dim isFirst As Long
    Dim targetWorkbookName As String
    Dim rowIndex
    currTime = Format(Now, "yyyy-mm-dd-hhmmss")
    isFirst = 0
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then strPath = .SelectedItems(1) Else Exit Sub
    End With
    
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
        
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        File = Dir(strPath & "*.xls") '一次找寻路径中的excel文件，这里到底是.xlsx还是.xls，可以自己改

        Do While File <> "" '当指定路径中由文件时进行循环
            Set sourceWorkbook = Workbooks.Open(strPath & File) '打开符合要求的文件
            If isFirst = 0 Then
                Set targetWorkbook = Workbooks.Add
                targetWorkbookName = sourceWorkbook.Name & "_" & "数据合并_" & currTime & ".xlsx"
                Set targetSheet = targetWorkbook.Worksheets(1)
                'targetSheet.Name = sourceWorkbook.Name
                sourceWorkbook.Worksheets(1).Range("A1:E2").Copy targetSheet.Cells(1, 1)
                sourceWorkbook.Worksheets(1).Range("E2:E2").Copy targetSheet.Cells(2, 6)
                targetSheet.Range("F2").Value = "设备类别"
                isFirst = 1
                rowIndex = 3
            End If
            Call DoCopyData(sourceWorkbook, targetSheet, rowIndex)
            sourceWorkbook.Close SaveChanges:=False '
            Set sourceWorkbook = Nothing
            File = Dir '找寻下一个excel文件
        Loop
        
        For Each columnTemp In targetSheet.Columns
            columnTemp.AutoFit
        Next
        
        If isFirst = 1 Then
            targetWorkbook.SaveAs Filename:=("D:\" & targetWorkbookName)
            targetWorkbook.Close SaveChanges:=True
            Set targetWorkbook = Nothing
        End If
        
        MsgBox "批量处理完成"
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
End Sub

Function DoCopyData(sourceWorkbook, targetSheet, rowIndex)
    Dim i As Integer
    Dim lastRow As Long
    Dim categry
    For Each ws In sourceWorkbook.Worksheets
       i = 3
       categry = ws.Name
       Do While Trim(ws.Range("A" & i).Value) <> "" Or Trim(ws.Range("B" & i).Value) <> "" Or Trim(ws.Range("D" & i).Value) <> ""
         If Len(Trim(ws.Range("D" & i).Value)) = 24 Then '资产编号为24位的
            ws.Range("A" & i & ":E" & i).Copy targetSheet.Cells(rowIndex, 1)
            ws.Range("E" & i & ":E" & i).Copy targetSheet.Cells(rowIndex, 6)
            targetSheet.Range("F" & rowIndex) = categry
            targetSheet.Range("A" & rowIndex) = rowIndex - 2
            rowIndex = rowIndex + 1
         End If
         i = i + 1
       Loop
    Next
End Function