EXCEL VBA 合并多张相同格式的工作表的宏

版权声明：转载请注明出处。 https://blog.csdn.net/Neil_001/article/details/81036185

不熟悉VBA的可以直接下载使用：下载打包的宏文件

熟悉VBA的可以拷贝我的代码文件自行粘贴或修改以进一步使用：

'时间：2018/7/13周四
'作者：Neil
'


Sub 表合并()
    
    Dim arr(200) As Long  #用于统计表数
    Dim str_arr(200) As String #用于计录文件名
    Dim i, n, n_f, r_i, c_i As Long
    
    file_path = ActiveWorkbook.Path + "\excel_files\"
    this_path = ActiveWorkbook.Name
    i = 0
    n = 0
    n_f = 0
    r_i = 0
    c_i = 0
    f = Dir(file_path)
    While f <> ""
        f_h = Left(f, 1)
        If f_h <> "~" Then
            Workbooks.Open (file_path + f)
            Windows(f).Activate
            ActiveWorkbook.Sheets(1).Select
            Range("A1").CurrentRegion.Select
            r_i = Selection.Rows.Count
            c_i = Selection.Columns.Count
            If i = 0 Then
                Range(Cells(1, 1), Cells(r_i, c_i)).Select
                Selection.Copy
            Else
                Range(Cells(2, 1), Cells(r_i, c_i)).Select
                Selection.Copy
            End If
            n_f = n_f + 1
            Debug.Print i
            Debug.Print r_i
            arr(i) = r_i - 1
            str_arr(i) = f
            Windows(this_path).Activate
            Sheets(Sheets.Count).Activate
            Range(Cells(n + 1, 1), Cells(n + r_i, c_i)).Select
            
            ActiveSheet.Paste
            ActiveSheet.Columns.AutoFit
            Range("A1").Activate
            
            If i = 0 Then
                n = n + r_i
            Else
                n = n + r_i - 1
            End If
            i = i + 1
            
        End If
        f = Dir
    Wend
    Windows(this_path).Activate
    Cells(1, 1).Activate
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Select
    Range("A1") = "file_name"
    Range("B1") = "number"
    i = 0
    While i < n_f
        Cells(i + 1, "A") = str_arr(i)
        Cells(i + 1, "B") = arr(i)
        i = i + 1
    Wend
    Cells(n_f + 1, "A") = "共 " + Str(n_f) + " 个文件"
    Cells(n_f + 1, "B") = "共 " + Str(n - 1) + " 行"
    ActiveSheet.Columns.AutoFit
    Range("A1").Activate

End Sub