Excel中VBA实现文件夹表格合并和数据提取

多个文件夹下excel文件的提取复制

Public Sub 取出文件()
Dim x1, x2, x3, x4, x5, arr
Dim mysheet1, fs, fo, fd, fi, fe
Dim path, tofile
'On Error Resume Next '忽略运行过程中可能出现的错误
Application.ScreenUpdating = False '关闭显示更新，提高运行速度
x1 = 2 '从第2行开始
'Set mysheet1 = ThisWorkbook.Worksheets("Sheet1") '定义Sheet1
path = ThisWorkbook.path + "\正常"
Set fs = CreateObject("Scripting.FileSystemObject") '访问计算机文件
Set fo = fs.GetFolder(path) '该路径下的文件夹
For Each fd In fo.SubFolders '获取该文件夹下面所有的子文件夹
'    Debug.Print fd.path
    Debug.Print fd.Name
    Set fo = fs.GetFolder(fd.path)
    Set fi = fo.Files
        For Each fe In fi '获取该文件夹下面所有的子文件
            Debug.Print fe.path
            tofile = ThisWorkbook.path + "\汇总\" + fd.Name + "+" + fe.Name '复制文件夹
            FileCopy fe.path, tofile
        Next
Next
Application.ScreenUpdating = True  '恢复显示更新
End Sub

获取多个文件夹下文件和文件夹信息

Public Sub 获取文件夹下文件信息()
Dim x1, x2, x3, x4, x5, arr
Dim mysheet1, fs, fo, fd, fi, fe
On Error Resume Next '忽略运行过程中可能出现的错误
Application.ScreenUpdating = False '关闭显示更新，提高运行速度
x1 = 2 '从第2行开始
Set mysheet1 = ThisWorkbook.Worksheets("Sheet1") '定义Sheet1
Set fs = CreateObject("Scripting.FileSystemObject") '访问计算机文件
mysheet1.Cells(x1, 1) = "C:\Users\Administrator\Desktop\汇总" '查找该文件夹《ABCD》下面所有的文件
For x2 = 2 To 1000000 '预计的文件夹数量
 If mysheet1.Cells(x2, 1) <> "" Then
  Set fo = fs.GetFolder(mysheet1.Cells(x2, 1)) '该路径下的文件夹
  For Each fd In fo.SubFolders '获取该文件夹下面所有的子文件夹
   x1 = x1 + 1
   arr = Array(fd.path, fd.Name, fd.Type, fd.DateCreated, fd.DateLastModified, fd.Size)
   '获取文件路径、名称、类型、创建时间、最后修改时间、大小
   For x5 = 0 To 5
    mysheet1.Cells(x1, x5 + 1) = arr(x5) '逐一写入单元格
   Next
  Next
 Else
  Exit For '退出For循环
 End If
Next
x4 = x1
For x3 = 2 To x4
 Set fo = fs.GetFolder(mysheet1.Cells(x3, 1))
 Set fi = fo.Files
 For Each fe In fi '获取该文件夹下面所有的子文件
  x1 = x1 + 1
  arr = Array(fe.path, fe.Name, fe.Type, fe.DateCreated, fe.DateLastModified, fe.Size)
  For x5 = 0 To 5
  mysheet1.Cells(x1, x5 + 1) = arr(x5)
  Next
 Next
Next
Application.ScreenUpdating = True  '恢复显示更新
End Sub

单独excel汇总

Public Sub 汇总()
On Error Resume Next
Dim MP, MN, AW, Wbn, wn
Dim wb As Workbook
Dim i, a, b, d, C, e, last_row, ni
Application.ScreenUpdating = False
MP = "C:\Users\Administrator\Desktop\汇总\6月园区奖金统计表汇总" '工作簿路径
MN = Dir(MP & "\" & "*.xlsx") '工作簿路径
AW = ActiveWorkbook.Name
Num = 0
ni = 0
e = 3 '标题栏数量
        
    craftName = "整理" '定义文件名
    last_row_clear = ThisWorkbook.Sheets(craftName).Cells(Rows.Count, "ai").End(xlUp).Row '最后一行位置
    If last_row_clear >= 2 Then
    ThisWorkbook.Sheets(craftName).Rows("2:" & last_row_clear).Delete
    End If
    
Do While MN <> ""
    If MN <> AW Then
    ni = ni + 1 '判断导入表的顺序
    Debug.Print "导入第" & ni & "表"
    Set wb = Workbooks.Open(MP & "\" & MN)
    a = a + 1
    '工作簿判断
'    Newbook.Sheets.Add.Name = ActiveWorkbook.Name & Wb.ActiveSheet.Name
  
   With ThisWorkbook.Sheets(craftName)
                d = wb.Sheets(craftName).UsedRange.Columns.Count '判断列数
                C = wb.Sheets(craftName).Cells(Rows.Count, "ai").End(xlUp).Row  'Wb.Sheets(1).UsedRange.Rows.Count - 1 '判断行数
                Debug.Print d & "=" & C
                Debug.Print wb.Sheets(craftName).Name&; "单表最后一行" & C
                last_row = .Cells(Rows.Count, "ai").End(xlUp).Row  '最后一行位置
                Debug.Print "终表最后一行" & last_row
                wb.Sheets(craftName).Range("A1:AL" & C).Copy .Cells(last_row + 1, 1) '复制数据
                wn = wb.Sheets(craftName).Name
                .Cells(4, "AM") = "表名"
                .Cells(e + 1, "AM").Resize(C - 2, 1) = MN & wn
                e = e + C '累计行数
             .Range("A:L").RowHeight = 12 '行高
            .Range("C:C").ColumnWidth = 35 '列宽
        Wbn = Wbn & Chr(13) & wb.Name
        wb.Close False
    End With
End If
MN = Dir
Loop
'Newbook.SaveAs Filename:=MP & "\" & "进出库汇总3.xlsx"
Range("a1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & a & "个工作薄下全部工作表。如下：" & Chr(13) & Wbn, vbInformation, "提示"
ThisWorkbook.Sheets(craftName).Range("A:AM").EntireColumn.AutoFit
End Sub

Public Sub 单独汇总()
'On Error Resume Next
Dim path
Dim wb
Dim name_old, nane_new, wn
Dim C, C1, C2, last_row
Dim file_name
Dim e
file_name = "钱塘&东港\东港&钱塘月度奖励发放统计表（6月）.xlsx" '汇总数据源表格路径
path = ThisWorkbook.path + "\6月园区奖金统计表汇总\" + file_name
Debug.Print ThisWorkbook.path
Set wb = Workbooks.Open(path)
'name_old = "园所转化奖金核算（6月）"
nane_new = "园所转化奖金核算（6月）" '目标工作表名称
    '第一张表
    With ThisWorkbook.Sheets(nane_new)
            C = wb.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row  'Wb.Sheets( last_row).UsedRange.Rows.Count - 1 '判断行数
            last_row = .Cells(Rows.Count, "A").End(xlUp).Row  '最后一行位置
            wb.Sheets(1).Range("A1:V" & C).Copy .Cells(last_row + 1, 1) '复制数据
            wn = wb.Sheets(1).Name
            .Cells(4, "W") = "表名"
            .Cells(last_row + 1, "W").Resize(C - 2, 1) = file_name & "/" & wn
'            e = e + C '累计行数
    End With
    '第二张表
    With ThisWorkbook.Sheets("普惠园月度托班招生人数奖励（6月）")
            C1 = wb.Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row  'Wb.Sheets( last_row).UsedRange.Rows.Count - 1 '判断行数
            last_row = .Cells(Rows.Count, "A").End(xlUp).Row  '最后一行位置
            wb.Sheets(2).Range("A1:H" & C1).Copy .Cells(last_row + 1, 1) '复制数据
            wn = wb.Sheets(2).Name
            .Cells(4, "I") = "表名"
            .Cells(last_row + 1, "I").Resize(C1 - 2, 1) = file_name & "/" & wn
'            e = e + last_row   '累计行数
            Debug.Print e
    End With
      '第三张表
    With ThisWorkbook.Sheets("课程顾问月度提成详表（6月）")
            C2 = wb.Sheets(3).Cells(Rows.Count, "A").End(xlUp).Row  'Wb.Sheets( last_row).UsedRange.Rows.Count - 1 '判断行数
            last_row = .Cells(Rows.Count, "A").End(xlUp).Row  '最后一行位置
            wb.Sheets(3).Range("A1:Z" & C2).Copy .Cells(last_row + 1, 1) '复制数据
            wn = wb.Sheets(3).Name
            .Cells(4, "AD") = "表名"
            .Cells(last_row + 1, "AD").Resize(C2 - 2, 1) = file_name & "/" & wn
'            e = e + last_row   '累计行数
'            Debug.Print e
    End With
    
    wb.Close False
End Sub

excel数据批量汇总‘

Sub 批量汇总()
Dim wb
Dim mypath, myfile, a, nane_new
Dim path
Dim name_old, wn
Dim C, C1, C2, last_row
Dim file_name
Dim e
mypath = ThisWorkbook.path + "\汇总\"
myfile = Dir(mypath, vbDirectory)
a = 1
Do While myfile <> ""
If myfile <> "." And myfile <> ".." Then
path = mypath + myfile
'Debug.Print path
Set wb = Workbooks.Open(path)
'name_old = "园所转化奖金核算（6月）"
nane_new = "园所转化奖金核算（6月）" '目标工作表名称
    '第一张表
    With ThisWorkbook.Sheets(nane_new)
            C = wb.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row  'Wb.Sheets( last_row).UsedRange.Rows.Count - 1 '判断行数
            last_row = .Cells(Rows.Count, "A").End(xlUp).Row  '最后一行位置
            wb.Sheets(1).Range("A1:V" & C).Copy .Cells(last_row + 1, 1) '复制数据
            wn = wb.Sheets(1).Name
            .Cells(4, "W") = "表名"
            .Cells(last_row + 2, "W").Resize(C - 1, 1) = myfile & "/" & wn
'            e = e + C '累计行数
    End With
    '第二张表
    With ThisWorkbook.Sheets("普惠园月度托班招生人数奖励（6月）")
            C1 = wb.Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row  'Wb.Sheets( last_row).UsedRange.Rows.Count - 1 '判断行数
            last_row = .Cells(Rows.Count, "A").End(xlUp).Row  '最后一行位置
            wb.Sheets(2).Range("A1:H" & C1).Copy .Cells(last_row + 1, 1) '复制数据
            wn = wb.Sheets(2).Name
            .Cells(4, "I") = "表名"
            .Cells(last_row + 2, "I").Resize(C1 - 1, 1) = myfile & "/" & wn
'            e = e + last_row   '累计行数
            Debug.Print e
    End With
      '第三张表
    With ThisWorkbook.Sheets("课程顾问月度提成详表（6月）")
            C2 = wb.Sheets(3).Cells(Rows.Count, "A").End(xlUp).Row  'Wb.Sheets( last_row).UsedRange.Rows.Count - 1 '判断行数
            last_row = .Cells(Rows.Count, "A").End(xlUp).Row  '最后一行位置
            wb.Sheets(3).Range("A1:Z" & C2).Copy .Cells(last_row + 1, 1) '复制数据
            wn = wb.Sheets(3).Name
            .Cells(4, "AD") = "表名"
            .Cells(last_row + 2, "AD").Resize(C2 - 1, 1) = myfile & "/" & wn
'            e = e + last_row   '累计行数
'            Debug.Print e
    End With
wb.Close False
a = a + 1
myfile = Dir
Else
myfile = Dir
End If
Loop
End Sub

’