多表格合并求助

薛定谔的加菲猫

各位大神：小弟每个月会统计各部门的一些数据，他们反馈过来的表格要合在一张表里。表格有一行表头，共31列，总行数不固定，求教CBA代码应该怎么写呢？下方的这段代码是从《别怕，VBA其实很简单里面复制出来的》，初学还不太懂，求大神帮忙改下，谢谢~

Sub 表格合并()
Dim bt As Range, r As Long, c As Long
r = 1
c = 31
Dim wt As Worksheet
Set wt = ThisWorkbook.Worksheets(1)
wt.Rows(r + 1 & ":1048576").ClearContents
Application.ScreenUpdating = False
Dim filename As String, sht As Worksheet, wb As Workbook
Dim erow As Long, fn As String, arr As Variant
filename = Dir(ThisWorkbook.Path & "\*.xlsx")
Do While filename <> ""
    If filename <> ThisWorkbook.Name Then
        erow = wt.Range("A1").CurrentRegion.Rows.Count + 1
        fn = ThisWorkbook.Path & "\" & filename
        Set wb = GetObject(fn)
        Set sht = wb.Worksheets(1)
        arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(1048576, "B").End(xlUp).Offset(0, 5))
        wt.Cells(erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        wb.Close False
    End If
    filename = Dir
  Loop
  Application.ScreenUpdating = True
End Sub

zhangzhang

无附件，很难得到帮助

薛定谔的加菲猫

zhangzhang 发表于 2018-8-7 14:37
无附件，很难得到帮助

文件都是被加密的  传上来也打不开的

魂断蓝桥

薛定谔的加菲猫 发表于 2018-8-7 14:46
文件都是被加密的  传上来也打不开的

高级模式中直接粘贴表格。
比如

日期	还款本金	还款利息	还款总金额	手续费
11/18/2017	1.5	0.3	1.8	0.0003
11/19/2017	3.5	0.7	4.2	0.0007
11/8/2017	7	1.4	8.4	0.014
合计:	12	2.4	14.4	0.015

LMY123

薛定谔的加菲猫 发表于 2018-8-7 14:46
文件都是被加密的  传上来也打不开的

上截图吧，一看工作薄是否在同一文件夹内及工作薄类型，二看工作表名称是否一样，或是否是首表

zhangzhang

薛定谔的加菲猫 发表于 2018-8-7 14:46
文件都是被加密的  传上来也打不开的

模拟数据就可以， 只要两三行 或 两三个 文件即可

薛定谔的加菲猫

LMY123 发表于 2018-8-7 14:56
上截图吧，一看工作薄是否在同一文件夹内及工作薄类型，二看工作表名称是否一样，或是否是首表

合并后放在第一个“00-总表”里，下方每个表的格式已经处理成一样的了

薛定谔的加菲猫

zhangzhang 发表于 2018-8-7 14:57
模拟数据就可以， 只要两三行 或 两三个 文件即可

公司电脑都不行，晚上下班回去做个模拟的表格传上来

LMY123

1. 'http://club.excelhome.net/thread-1341555-1-1.html
   
2. Sub 同夹多薄首表合并成一薄一表()
   
3.   Dim cnn As Object, SQL As String, MyPath$, MyFile$, n As Long
   
4. '  Cells.Clear
   
5.   Set cnn = CreateObject("ADODB.Connection")
   
6.   MyPath = ThisWorkbook.Path & ""
   
7.   MyFile = Dir(MyPath & "*.xlsx")
   
8.   Do While MyFile <> ""
   
9.      If MyFile <> ThisWorkbook.Name Then
   
10.         n = n + 1
    
11.         If n = 1 Then
    
12.             cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=no';Data Source=" & MyPath & MyFile
    
13.            SQL = "SELECT * FROM [$A2:AE] WHERE F1 IS NOT NULL"
    
14.         Else
    
15.            SQL = SQL & " UNION ALL SELECT * FROM [Excel 12.0;HDR=NO;Database=" & MyPath & MyFile & "].[$A2:AE] "
    
16.         End If
    
17.      End If
    
18.     MyFile = Dir()
    
19.   Loop
    
20.   Range("A2").CopyFromRecordset cnn.Execute(SQL)
    
21.   cnn.Close
    
22.   Set cnn = Nothing
    
23. End Sub

复制代码

薛定谔的加菲猫

LMY123 发表于 2018-8-7 15:16

运行时会提示这个，提示红框的那行代码