如何在同一文件夹跨工作表取数

cuang2002

q压缩文件夹中有四家公司。现在想用VBA实现公司数据汇总，汇总表里的数据，请高手帮忙！ q.zip (27.98 KB, 下载次数: 31)

2013-2-28 18:40 上传

点击文件名下载附件

zhaogang1960

前提：各个工作簿数据区完全相同，相同单元格累加：

1. Sub Macro1()
   
2.     Dim MyPath$, MyName$, arr, brr(1 To 29, 1 To 6), i&, j&
   
3.     Application.ScreenUpdating = False
   
4.     MyPath = ThisWorkbook.Path & ""
   
5.     MyName = Dir(MyPath & "*.xls")
   
6.     Do While MyName <> ""
   
7.         If MyName <> ThisWorkbook.Name Then
   
8.             With GetObject(MyPath & MyName)
   
9.                 arr = .Sheets(1).Range("C6:H34")
   
10.                 .Close False
    
11.             End With
    
12.             For i = 1 To 29
    
13.                 For j = 1 To 6
    
14.                     brr(i, j) = brr(i, j) + arr(i, j)
    
15.                 Next
    
16.             Next
    
17.         End If
    
18.         MyName = Dir
    
19.     Loop
    
20.     Range("C6:H34") = brr
    
21.     Application.ScreenUpdating = True
    
22. End Sub
    

复制代码

zhaogang1960

请看附件
q.rar (31.1 KB, 下载次数: 68)

2013-2-28 19:05 上传

点击文件名下载附件

cuang2002

为什么汇总的数据跟我用公式汇总的数据不一样。。

cuang2002

外单位拔入(+)
拔出(-)  是公司的累加。。这个数据不一样。。

opiona

1. 
   
2. '*********************************
   
3. '*******  北极狐工作室出品  ******
   
4. '*******  QQ：14885553      ******
   
5. '*********************************
   
6. 
   
7. Sub Opiona()
   
8. 
   
9. 'On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
   
10. Application.ScreenUpdating = False '//关闭屏幕刷新
    
11. Application.DisplayAlerts = False '//关闭系统提示
    
12. 
    
13. t = Timer   '//开始时间
    
14. 
    
15.     Str1 = "企管01表"
    
16.     Set SH1 = Sheets(Str1)
    
17.     Set SH2 = Sheets("临时表")
    
18.     SH1.Range("C6:Z34").ClearContents
    
19.     SH2.Range("A4:Z65536").ClearContents
    
20.     arr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name)
    
21.     For I = 0 To UBound(arr)
    
22.         StrCoon = "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=NO';Data Source=" & arr(I)   '//OFFICE2003
    
23.         StrSQL = "SELECT * FROM [" & Str1 & "$A6:Q65536] WHERE LEN(F1)>0"
    
24.         If I = 0 Then R = 4 Else R = SH2.Range("A65536").End(3).Row + 1
    
25.         SH2.Range("A" & R).CopyFromRecordset GET_SQLRS(StrSQL, StrCoon)
    
26.     Next
    
27.     StrCoon = "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=NO';Data Source=" & ThisWorkbook.FullName
    
28.     StrSQL = "SELECT B.BT2,B.BT3,B.BT4,B.BT5,B.BT6,B.BT7 FROM"
    
29.     StrSQL = StrSQL & " (SELECT F1 AS BT1 FROM [" & SH1.Name & "$A6:A65536]) AS A LEFT JOIN"
    
30.     StrSQL = StrSQL & " (SELECT F1 AS BT1,SUM(F3) AS BT2,SUM(F9)+SUM(F11)+SUM(F13) AS BT3,SUM(F10)+SUM(F12)+SUM(F14) AS BT4,SUM(F15) AS BT5,SUM(F16) AS BT6,SUM(F17) AS BT7 FROM [" & SH2.Name & "$A4:Q65536] WHERE LEN(F1)>0 GROUP BY F1) AS B"
    
31.     StrSQL = StrSQL & " ON TRIM(A.BT1)= TRIM(B.BT1)"
    
32.     SH1.Range("C6").CopyFromRecordset GET_SQLRS(StrSQL, StrCoon)
    
33. Application.ScreenUpdating = True '//恢复屏幕刷新
    
34. Application.DisplayAlerts = True '//恢复系统提示
    
35. MsgBox "一共用时：" & Format(Timer - t, "#0.0000") & " 秒", , "北极狐提示!!"  '//提示所用时间
    
36. End Sub
    
37. 
    
38. '*****************************************************************************************
    
39. '函数名：    GET_SQLRS
    
40. '函数功能：  获得指定SQL的查询结果，修改CN连接字符串，可以连接各种数据库
    
41. '返回值：    返回一个recordset数据集
    
42. '参数1：     StrSQL   字符类型   SQL查询语句
    
43. '使用方法： Set RS = CreateObject("adodb.recordset")  '//先引用ADO：Microsoft ActiveX Data Objects 2.5 或更高版本
    
44.             'Set RS = GET_SQLRS(StrSQL,StrCoon)
    
45.             'Sh1.Range("A2").CopyFromRecordset RS
    
46. '*****************************************************************************************
    
47. Public Function GET_SQLRS(ByVal StrSQL As String, ByVal Str_coon As String) As ADODB.Recordset
    
48. On Error Resume Next    ' 改变错误处理的方式。
    
49. Dim CN, RS
    
50.     Err.Clear
    
51.     Set CN = CreateObject("Adodb.Connection") '//新建一个ADO连接
    
52.     Set RS = CreateObject("adodb.recordset")
    
53.     CN.Open Str_coon
    
54.     RS.Open StrSQL, CN, 1, 3
    
55.     Set GET_SQLRS = RS
    
56. GET_SQLRS_Exit:
    
57.     Exit Function
    
58. GET_SQLRS_Error:
    
59.     MsgBox Err.Description
    
60.     Resume GET_SQLRS_Exit
    
61. End Function
    
62. 
    
63. '****************************************************************
    
64. '功能：    查找指定文件夹含子文件夹内所有文件名（含路径）
    
65. '函数名：  FileAllArr
    
66. '参数1：   Filename    需查找的文件夹名 不含最后的""
    
67. '参数2：   FileFilter  需要过滤的文件名，可省略，默认为：[*.*]
    
68. '参数3：   Liwai       剔除例外的文件名，可省略，默认为：空，一般为：ThisWorkbook.Name
    
69. '返回值：  一个字符型的数组
    
70. '使用方法：arr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name)
    
71. 
    
72. Public Function FileAllArr(ByVal Filename As String, Optional ByVal FileFilter As String = "*.*", Optional ByVal Liwai As String = "") As String()
    
73.     Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    
74.     Set Did = CreateObject("Scripting.Dictionary")
    
75.     Dic.Add (Filename & ""), ""
    
76.     I = 0
    
77.     Do While I < Dic.Count
    
78.         Ke = Dic.keys   '开始遍历字典
    
79.         MyName = Dir(Ke(I), vbDirectory)    '查找目录
    
80.         Do While MyName <> ""
    
81.             If MyName <> "." And MyName <> ".." Then
    
82.                 If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
    
83.                     Dic.Add (Ke(I) & MyName & ""), ""  '就往字典中添加这个次级目录名作为一个条目
    
84.                 End If
    
85.             End If
    
86.             MyName = Dir    '继续遍历寻找
    
87.         Loop
    
88.         I = I + 1
    
89.     Loop
    
90.   
    
91. I = 0
    
92. Dim arrx() As String
    
93.     For Each Ke In Dic.keys '以查找总表所在文件夹下所有excel文件为例
    
94.         MyFileName = Dir(Ke & FileFilter) '过滤器：EXCEL2003为：*.xls,excel2007为：*.xlsx
    
95.         Do While MyFileName <> ""
    
96.            If MyFileName <> Liwai Then '排除例外文件
    
97.               ReDim Preserve arrx(I)
    
98.               arrx(I) = Ke & MyFileName
    
99.               I = I + 1
    
100.            End If
     
101.             MyFileName = Dir
     
102.         Loop
     
103.     Next
     
104.     FileAllArr = arrx
     
105. End Function
     
106. '****************************************************************
     
107. 
     
108. 
     

复制代码

opiona

q.rar (38.88 KB, 下载次数: 42)

2013-2-28 19:31 上传

点击文件名下载附件

A工作簿少有修改，要注意哟！

zhaogang1960

cuang2002 发表于 2013-2-28 19:19
外单位拔入(+)
拔出(-)  是公司的累加。。这个数据不一样。。

我不认识公式，全部完成了累加，请说明怎么计算

cuang2002

A公司（外单位拔入(+)拔出(-) +    外单位拔入(+)拔出(-) +     外单位拔入(+)拔出(-)）+公司（外单位拔入(+)拔出(-) +    外单位拔入(+)拔出(-) +     外单位拔入(+)拔出(-)）+公司（外单位拔入(+)拔出(-) +    外单位拔入(+)拔出(-) +     外单位拔入(+)拔出(-)）我是想三家公司三个部门中的拨入拨出数相加。。。帐面拨入拨出数也相加。。

cuang2002

我汇总表上都有设置简单的公式相加。。