合并文件到当前工作表升级版

cain030

     在前人的基础上改量了一下，对小白更加友好，哈哈哈哈哈。直接弹框按提示填基础资料。这个程序适用于只汇总工作簿中的第一张表，而且表格最大只有65536行。就是适用于大部分系统导出表格的合并。

1. Sub 合并文件到当前工作表()
   
2.     Dim r As Long, a, b, c As Long, Rng, d As String, p$, f$, txt$
   
3.     Rng = Application.InputBox("输入需要合并的表头行数及列数,用-符合隔开", "设置", "1-1", , , , , 2) '录入表头行数和列数
   
4.         If Rng = "False" Then '如果是取消录入行列则退出程序
   
5.         MsgBox ("已取消")
   
6.         Exit Sub
   
7.         End If
   
8.     r = Split(Rng, "-")(0) '取表头行数
   
9.     c = Split(Rng, "-")(1) '取表头列数
   
10.     d = Application.InputBox("输入此表表头行数", "设置", "1", , , , , 1) '录入此表表头行数
    
11.         If d = "False" Then '如果是取消录入行列则退出程序
    
12.         MsgBox ("已取消")
    
13.         Exit Sub
    
14.         End If
    
15.     Rng2 = Application.InputBox("输入需要处理的文件格式{例如：csv;xlsx;xls;xls*(推荐)}", "设置", "xls*", , , , , 2) '录入需要历遍的文件格式
    
16.         If Rng2 = "False" Then '如果是取消录入则退出程序
    
17.         MsgBox ("已取消")
    
18.         Exit Sub
    
19.         End If
    
20.     result = MsgBox("是否清除原表内容", 3, "选择一个选项") '判断是否需要清除原表内容
    
21.     If result = 6 Then '6就是确定要清除原表内容
    
22.     a = Range("A1").CurrentRegion.Rows.Count
    
23.     b = Range("A1").CurrentRegion.Columns.Count
    
24.         If a - 1 <> 0 Then
    
25.         Range(Cells(d + 1, 1), Cells(a, b)).ClearContents ' 清除汇总表中原表数据,从标题行以下全部清除
    
26.         End If
    
27.     ElseIf result = 2 Then '2就是取消，则退出程序
    
28.     Exit Sub
    
29.     End If
    
30.     Application.ScreenUpdating = False
    
31.     Dim filename As String, wb As Workbook, sht As Worksheet, erow As Long, _
    
32.         fn As String, arr As Variant
    
33.     filename = Dir(ActiveWorkbook.Path & "\*." & Rng2) ' 统计文件的数据
    
34.     Do While filename <> ""
    
35.         If filename <> ActiveWorkbook.Name Then '判断文件是否是本工作薄
    
36.             erow = Range("A1").CurrentRegion.Rows.Count + 1 '取得汇总表中第一条空行行号
    
37.             fn = ActiveWorkbook.Path & "" & filename
    
38.             Set wb = GetObject(fn) '将fn代表的工作薄对象赋给变量
    
39.             Set sht = wb.Worksheets(1) '汇总的是第1张工作表
    
40.             '将数据表中的记录保存在arr数组里
    
41.             erow2 = sht.Range("A65536").End(xlUp).Row '取得表格最后一行行号(A列最后一个非空单元格)
    
42.             arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(erow2, "B").Offset(0, c))
    
43.             For i = 1 To erow2 - r
    
44.             arr(i, c + 1) = filename
    
45.             arr(i, c + 2) = sht.Name
    
46.             Next
    
47.             '将数组arr中的数据写入工作表
    
48.             Cells(erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    
49.             wb.Close False
    
50.         End If
    
51.         filename = Dir '用Dir函数去找下一个符合条件的文件，并赋给变量
    
52.     Loop
    
53.     Cells(d, c + 1).Value = "工作簿名"
    
54.     Cells(d, c + 2).Value = "工作表名"
    
55.     Application.ScreenUpdating = TURE
    
56.     MsgBox "修改完成!"
    
57. End Sub

复制代码

xj123321

有附件吗