求助：汇总合并报表

wnxzzw

将同一文件夹下1月财务报表、2月财务报表……等多个报表整理到一个工作表，以便财务分析。
代码如下：
Sub zchz()
    Application.ScreenUpdating = False                                    '关闭屏幕更新
    Dim zc As Worksheet
    Dim wb As Worksheet
   
    Dim i As Integer, n As Integer
   
         
    Set zc = Worksheets("资产负债表汇总")                                 '指定汇总表表格名称
        zc.Range("A1:B1,A2:N68").ClearContents                            '清除区域数据
        zc.Range("A1:B1") = Array("单位：", "万元")                       '添加表头
        zc.Range("A2") = "项目"                                           '添加表头
        
        Workbooks.Open Filename:=ActiveWorkbook.Path & "\1月财务报表.xls"
        Workbooks("1月财务报表.xls").Worksheets(1).Range("A6:A38").Copy
        zc.Range("A3").PasteSpecial Paste:=xlPasteValues    '粘贴数据
        Workbooks("1月财务报表.xls").Worksheets(1).Range("E6:E38").Copy
        zc.Range("A36").PasteSpecial Paste:=xlPasteValues   '粘贴数据
        
        zc.Range("B2") = "年初数"
        Workbooks("1月财务报表.xls").Worksheets(1).Range("D6:D38").Copy       '复制期初资产数据
        zc.Range("B3").PasteSpecial Paste:=xlPasteValues                                          '粘贴数据
        
        Workbooks("1月财务报表.xls").Worksheets(1).Range("H6:H38").Copy       '复制期初负债及权益数据
        zc.Range("B36").PasteSpecial Paste:=xlPasteValues                                     '粘贴数据
      
    Workbooks("1月财务报表.xls").Close savechanges:=False   '关闭刚打开的工作簿
    Dim dirname As String
    Dim nm As String
   
    lj = ActiveWorkbook.Path
    dirname = Dir(lj & "\*.xls")
   
    Do While dirname <> ""
        dirname = Dir
   
               For i = 1 To n - 1
   
        Set wb = Workbooks.Open(lj & "\ " & i & "月财务报表.xls")
        Workbooks(wb).Sheets(1).Range("C6:C38").Copy                                    '复制当月资产数据
        zc.Cells(3, k + 2).PasteSpecial Paste:=xlPasteValues                            '粘贴数据
        
        Workbooks(wb).Worksheets(1).Range("G6:G38").Copy                                     '复制当月负债及权益数据
        zc.Cells(36, i + 1).PasteSpecial Paste:=xlPasteValues                 '粘贴数据
        
    Workbooks(wb).Close savechanges:=False   '关闭刚打开的工作簿
                Next i                                  '循环下一条
      
    Loop
End Sub
DO while ……LOOP循环有点问题，不能按1月、2月等顺序执行复制粘贴报表，请高手指教。

wnxzzw

肯请各位高手解救，谢谢

opiona

1. '*********************************
   
2. '*******  北极狐工作室出品  ******
   
3. '*******  QQ：14885553      ******
   
4. '*********************************
   
5. 
   
6. Sub Opiona()
   
7. 
   
8. 'On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
   
9. Application.ScreenUpdating = False '//关闭屏幕刷新
   
10. Application.DisplayAlerts = False '//关闭系统提示
    
11. t = Timer   '//开始时间
    
12. 
    
13.     Set SH2 = Sheets("资产负债表汇总")
    
14.     SH2.Range("C1:AZ65536").ClearContents
    
15.    FileArr = FileAllArr(ThisWorkbook.Path, "*.xls?", ThisWorkbook.Name, False)
    
16.    For i = 0 To UBound(FileArr)
    
17.    
    
18.       Str_coon = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source =" & FileArr(i)    '//OFFICE2007
    
19.       StrSQL = "SELECT B.年初余额 FROM ("
    
20.       StrSQL = StrSQL & "SELECT F1 AS 资产 FROM [Excel 12.0;HDR=NO;Database=" & ThisWorkbook.FullName & "].[资产负债表汇总$A3:A100]"
    
21.       StrSQL = StrSQL & ") AS A LEFT JOIN (      "
    
22.       StrSQL = StrSQL & "SELECT F1 AS 资产,F3 AS 期末余额,F4 AS 年初余额 FROM [资产负债表$A6:D38] WHERE LEN(F1)>0"
    
23.       StrSQL = StrSQL & " UNION ALL "
    
24.       StrSQL = StrSQL & " SELECT F1 AS 资产,F3 AS 期末余额,F4 AS 年初余额 FROM [资产负债表$E6:H38] WHERE LEN(F1)>0"
    
25.       StrSQL = StrSQL & ") AS B ON A.资产=B.资产"
    
26.       SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, False)
    
27.       SH2.Cells(2, i + 3) = Replace(GetPathFromFileName(FileArr(i)), "财务报表", "")  '//想要正确按照月份排序，命名应该为：01月、02月10月
    
28.       SH2.Range(SH2.Cells(3, i + 3).Address).Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR
    
29.       
    
30.    Next i
    
31. Application.ScreenUpdating = True '//恢复屏幕刷新
    
32. Application.DisplayAlerts = True '//恢复系统提示
    
33. MsgBox "一共用时：" & Format(Timer - t, "#0.0000") & " 秒", , "北极狐提示!!"  '//提示所用时间
    
34. End Sub

复制代码

opiona

完整代码和自定义函数见附件：

wnxzzw

谢谢，就是SQL还有点看不太懂。总之非常感谢

XZ19860527

顶    顶顶

hdlgz

顶顶，狂顶

caozhididi

顶啊 非常感谢楼主

LMY123

ADO多薄单表

Adam-r

进来学习一下,谢谢分享