多工作簿汇总

xyd617

1、第2行从B2开始列示汇总的数据源工作簿名称

2、从B列开始列示第2行相应工作簿中指定data工作表B7到B170的数据。

3、需汇总工作簿比较多。
因工作簿较多，且是纵向增加，求助大神！谢谢

不知道为什么

思路很清晰了啊，论坛多簿汇总代码很多，自己可以试试

不知道为什么

http://club.excelhome.net/forum. ... p;page=1#pid9603184

和你得需求基本很类似，供参考

lsc900707

1. Sub test()
   
2.     Application.ScreenUpdating = False
   
3.     Range("b:iv").ClearContents
   
4.     Set fso = CreateObject("scripting.filesystemobject")
   
5.     Set ff = fso.getfolder(ThisWorkbook.Path)
   
6.     tc = 1
   
7.     For Each f In ff.Files
   
8.         If f.Name <> ThisWorkbook.Name Then
   
9.             Workbooks.Open f
   
10.             tc = tc + 1
    
11.             With ThisWorkbook.Sheets(2)
    
12.                  .Cells(2, tc) = Split(f.Name, ".")(0)
    
13.                  Sheets(2).Range("b7:b170").Copy .Cells(3, tc)
    
14.             End With
    
15.             ActiveWorkbook.Close False
    
16.         End If
    
17.     Next
    
18.     Application.ScreenUpdating = True
    
19. End Sub

复制代码

jjmysjg

夹内工作簿横向合并，科目变化不能合并

lsc900707

附件供测试：

xiangbaoan

Sub test()
Dim p$, fl, cnn As Object, rst As Object, Str_cnn$, sql$, f, st$, nm$, k%
p = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Set fl = CreateObject("Scripting.FileSystemObject").GetFolder(p).Files
For Each f In fl
    If f.Name <> ThisWorkbook.Name And InStr(f.Name, ".xls") Then
        k = k + 1
        nm = Split(f.Name, ".")(0)
        If Application.Version < 12 Then
            Str_cnn = "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" & f
        Else
            Str_cnn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=no';Data Source=" & f
        End If
        Set cnn = CreateObject("adodb.connection")
        cnn.Open Str_cnn
        sql = "select * from [data$b7:b170]"
        Set rst = cnn.Execute(sql)
        With ThisWorkbook.Sheets(2)
            .Cells(2, k + 1) = nm
            .Cells(3, k + 1).CopyFromRecordset rst
        End With
    End If
Next
cnn.Close
Set cnn = Nothing
Set rst = Nothing
Set fl = Nothing
Application.ScreenUpdating = True
End Sub

xyd617

xiangbaoan 发表于 2018-7-30 22:48
Sub test()
Dim p$, fl, cnn As Object, rst As Object, Str_cnn$, sql$, f, st$, nm$, k%
p = ThisWorkb ...

不知为什么，我用这个会出错，如图所示，需要怎么调试下么？

xiangbaoan

我这里没问题，至于你那里出现的问题，我不清楚，下面是附件。
补充：

猜想，当前文件夹中没有汇总的文件，或者没将此文件与汇总文件放在一起。

xyd617

123444444444444444445