使用VBA汇总文件夹下所有Excel文件

Posted 2022-03-09 但老师

环境

• VBA
• 文件夹下有13个Excel,结构相同
  • 所有Excel的第1个表为"汇总"或者"目录",其他表为具体的内容
  • 所有汇总表的结构一样,从第3行开始为内容,只在A-F列有内容,但是最后一行可能会有汇总在E列

需求

• 最终返回1个Excel
• 将所有表的"汇总"或"目录"表上下合并成1张大表
• 分表全部放在汇总表后面

也就是相当于从

• n个a11111结构的表

变成

• 1个A11111111结构的表

VBA代码

Sub Dan()
    ' 主程序
    Dim filepaths$
    Dim a, arrfile, Arr
    Dim Wkb As Workbook, Sht As Worksheet
    Dim theWkb As Workbook, theSht As Worksheet
    Dim endRow%, i%, j%
    
    Call deleteAllOthers
    filepaths = getCurFiles()
    arrfile = Split(filepaths, "|")
    Set theWkb = ThisWorkbook
    Set theSht = Sheet1
    For Each a In arrfile
        Set Wkb = Workbooks.Open(a)
        For Each Sht In Wkb.Sheets
            If Sht.Name = "目录" Or Sht.Name = "汇总" Then
                Arr = Sht.UsedRange
                With theSht
                    For i = 3 To UBound(Arr)
                        If Len(Arr(i, 1)) > 0 Then
                            endRow = .Cells(.Rows.Count, 1).End(3).Row + 1
                            For j = LBound(Arr, 2) To 6
                                .Cells(endRow, j).Value = Arr(i, j)
                            Next
                        End If
                    Next
                End With
            Else
                Sht.Copy after:=theSht
            End If
        Next
        Wkb.Close 0
    Next
End Sub

Function getCurFiles() As String()
    ' 获取当前文件夹所有文件
    Dim Folder$, Filename$, Filepath$, filepaths(), arrCount%
    Folder = "D:\\OneDrive\\桌面\\隽悦雅苑\\"
    Filename = Dir(Folder)
    While Filename <> ""
        If Filename <> ThisWorkbook.Name Then
            ReDim Preserve filepaths(0 To arrCount)
            Filepath = Folder + Filename
            filepaths(arrCount) = Filepath
            arrCount = arrCount + 1
        End If
        Filename = Dir
    Wend
    getCurFiles = Join(filepaths, "|")
End Function

Sub deleteAllOthers()
    ' 在当前工作簿删除除了汇总以外的所有其他表
    Dim Sht As Worksheet
    On Error Resume Next
    For Each Sht In ThisWorkbook.Sheets
        If Sht.Name <> Sheet1.Name Then
            Sht.Delete
        End If
    Next
    Debug.Print "All Deleted"
End Sub

Sub test()
     x = getCurFiles
     Debug.Print x
End Sub

- 完 -