求自动汇总工作簿的宏

dyqn_2002 · 发表于 2012-11-12 15:06

我每月要作各地的销售统计，各地的销售报表分别放在相应的文件夹下，求前辈帮我做个宏，能够自动采集这些数据到汇总表，次月采集时延续在汇总表末端（不必考虑分表的延续，分表每月都是新的，但格式相同）

zhaogang1960 · 发表于 2012-11-12 15:42

请测试：

Sub Macro1()
Dim cnn As Object, SQL$, m&, n&, t$, Fso As Object, arrf$(), mf&
Application.ScreenUpdating = False
Set Fso = CreateObject("Scripting.FileSystemObject")
sFileType = "*.xlsx"
Call GetFiles(ThisWorkbook.Path, sFileType, Fso, arrf, mf)
ActiveSheet.UsedRange.Offset(1).ClearContents
Set cnn = CreateObject("ADODB.Connection")
For n = 1 To mf
If n = 1 Then
cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & arrf(n)
Else
t = "[Excel 12.0;Database=" & arrf(n) & "]."
End If
m = m + 1
If m > 49 Then
Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
m = 1
SQL = ""
End If
If Len(SQL) Then SQL = SQL & " union all "
SQL = SQL & "select * from " & t & "[Sheet1$] where 地区 is not null"
Next
If Len(SQL) Then Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
cnn.Close
Set cnn = Nothing
Set Fso = Nothing
Application.ScreenUpdating = True
End Sub
Private Sub GetFiles(ByVal sPath$, ByVal sFileType$, ByRef Fso As Object, ByRef arrf$(), ByRef mf&)
Dim Folder As Object
Dim SubFolder As Object
Dim File As Object
Set Folder = Fso.GetFolder(sPath)
For Each File In Folder.Files
If File.Name Like sFileType Then
If File.Name <> ThisWorkbook.Name Then
mf = mf + 1
ReDim Preserve arrf(1 To mf)
arrf(mf) = sPath & "" & File.Name
End If
End If
Next
If Folder.SubFolders.Count > 0 Then
For Each SubFolder In Folder.SubFolders
Call GetFiles(SubFolder.Path, sFileType, Fso, arrf, mf)
Next
End If
Set Folder = Nothing
Set File = Nothing
Set SubFolder = Nothing
End Sub

复制代码

zhaogang1960 · 发表于 2012-11-12 15:43

请看附件

销售数据汇总.rar (50.57 KB, 下载次数: 90)

秋鹭飘零 · 发表于 2012-11-12 22:28

学习了先。。。。。。。。。。

dyqn_2002 · 发表于 2012-11-14 14:22

谢谢赵老师，我先去研究下

dyqn_2002 · 发表于 2012-11-16 09:12

再次感谢赵老师，很实用，通过远程登录操作软件再加上您编写的宏，轻松搞定汇总工作！

dyqn_2002 · 发表于 2012-11-16 17:14

赵老师，我现在想增加几列，并且从第分表的第四行开始取数据（还是粘到主表第二行），请问该如何操作？

zhaogang1960 · 发表于 2012-11-16 17:35

dyqn_2002 发表于 2012-11-16 17:14
赵老师，我现在想增加几列，并且从第分表的第四行开始取数据（还是粘到主表第二行），请问该如何操作？

现在脑子有点乱，请模拟效果说明吧

dyqn_2002 · 发表于 2012-11-19 11:19

原设计汇总分表的宏是取分表的前五列，如果想增加或减少汇总的列，请问修改宏语句里面的哪一行？，如果想从分表的第四行开始取数，请问如何修改宏？

zhaogang1960 · 发表于 2012-11-19 14:36

本帖最后由 zhaogang1960 于 2012-11-19 14:37 编辑

dyqn_2002 发表于 2012-11-19 11:19
原设计汇总分表的宏是取分表的前五列，如果想增加或减少汇总的列，请问修改宏语句里面的哪一行？，如果想从 ...

Sub Macro1()
Dim cnn As Object, SQL$, m&, n&, t$, Fso As Object, arrf$(), mf&
Application.ScreenUpdating = False
Set Fso = CreateObject("Scripting.FileSystemObject")
sFileType = "*.xlsx"
Call GetFiles(ThisWorkbook.Path, sFileType, Fso, arrf, mf)
ActiveSheet.UsedRange.Offset(1, 3).ClearContents '清除D:E原数据
Set cnn = CreateObject("ADODB.Connection")
For n = 1 To mf
If n = 1 Then
cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=no';Data Source=" & arrf(n) '改为无标题
Else
t = "[Excel 12.0;hdr=no;Database=" & arrf(n) & "]." '改为无标题
End If
m = m + 1
If m > 49 Then
Range("d" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL) '复制到D列
m = 1
SQL = ""
End If
If Len(SQL) Then SQL = SQL & " union all "
SQL = SQL & "select * from " & t & "[Sheet1$d4:e] where f1 is not null" '这里数据区域为d4:e，并使用f1、f2……表示字段名
Next
If Len(SQL) Then Range("d" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL) '复制到D列
cnn.Close
Set cnn = Nothing
Set Fso = Nothing
Application.ScreenUpdating = True
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[求助] 求自动汇总工作簿的宏