[已解决]求助跨表汇总

云影

问题在附件里，谢谢

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-1-3 00:05

问题在这里分析表 .rar (26.76 KB, 下载次数: 56)

2013-1-3 00:18 上传

点击文件名下载附件

跳转到最佳答案楼层

hwc2ycy

最头疼的莫过于跨表，

云影

hwc2ycy 发表于 2013-1-2 23:08
最头疼的莫过于跨表，

啊连老师都头疼吗{:081:}

hwc2ycy

1. Option Explicit
   
2. 
   
3. Sub 合并统计()
   
4.     Dim arrXL, arrKC, arrDD
   
5.     Dim FileXL$, FileKC$, FileDD$
   
6.     Dim result, iPos&
   
7.     Dim i&, j&
   
8.     Dim app As Object
   
9.     Dim t#
   
10.    
    
11.     FileXL = "销量.xlsx"
    
12.     FileKC = "库存.xlsx"
    
13.     FileDD = "订单.xlsx"
    
14.    
    
15.     t = Timer
    
16.     On Error Resume Next
    
17.     Set app = CreateObject("excel.application")
    
18.     app.AutomationSecurity = msoAutomationSecurityForceDisable
    
19.    
    
20.     '销量
    
21.     app.Workbooks.Open ThisWorkbook.Path & "" & FileXL, False, True
    
22.     If Len(app.Workbooks(FileXL).Name) = 0 Then
    
23.         MsgBox FileXL & " 访问失败"
    
24.         Exit Sub
    
25.     End If
    
26.     With app.Workbooks(FileXL).Worksheets("sheet1")
    
27.         arrXL = .Range("a1").CurrentRegion
    
28.     End With
    
29.     app.Workbooks(FileXL).Close False
    
30. 
    
31.     '库存
    
32.     app.Workbooks.Open ThisWorkbook.Path & "" & FileKC, False, True
    
33.     If Len(app.Workbooks(FileKC).Name) = 0 Then
    
34.         MsgBox FileKC & " 访问失败"
    
35.         Exit Sub
    
36.     End If
    
37.     With app.Workbooks(FileKC).Worksheets("sheet1")
    
38.         arrKC = .Range("a1").CurrentRegion
    
39.     End With
    
40.     app.Workbooks(FileKC).Close False
    
41. 
    
42.     '订单
    
43.     app.Workbooks.Open ThisWorkbook.Path & "" & FileDD, False, True
    
44.     If Len(app.Workbooks(FileDD).Name) = 0 Then
    
45.         MsgBox FileDD & " 访问失败"
    
46.         Exit Sub
    
47.     End If
    
48.     With app.Workbooks(FileDD).Worksheets("sheet1")
    
49.         arrDD = .Range("a1").CurrentRegion
    
50.     End With
    
51.     app.Workbooks(FileDD).Close False
    
52. 
    
53.     app.AutomationSecurity = msoAutomationSecurityByUI
    
54.     Set app = Nothing
    
55. 
    
56.     ReDim result(1 To UBound(arrDD), 1 To 3)
    
57.     Dim dic As Object, dickc As Object
    
58.     Set dic = CreateObject("scripting.dictionary")
    
59.     Set dickc = CreateObject("scripting.dictionary")
    
60.    
    
61.     iPos = 1
    
62.     '订单统计
    
63.     For i = 2 To UBound(arrDD)
    
64.         If Not dic.exists(arrDD(i, 1)) Then
    
65.             iPos = iPos + 1
    
66.             result(iPos, 1) = arrDD(i, 1)
    
67.             result(iPos, 2) = arrDD(i, 2)
    
68.             dic(arrDD(i, 1)) = iPos
    
69.         Else
    
70.             j = dic(arrDD(i, 1))
    
71.             result(j, 2) = result(j, 2) + arrDD(i, 2)
    
72.         End If
    
73.     Next
    
74.    
    
75.     '销量统计
    
76.     For i = 2 To UBound(arrXL)
    
77.         If dic.exists(arrXL(i, 1)) Then
    
78.             iPos = dic(arrXL(i, 1))
    
79.             result(iPos, 3) = arrDD(i, 2)
    
80.         End If
    
81.     Next
    
82.    
    
83.     '库存统计
    
84.     iPos = UBound(result, 2)
    
85.     For i = 2 To UBound(arrKC)
    
86.         If Not dickc.exists(arrKC(i, 1)) Then
    
87.             iPos = iPos + 1
    
88.             ReDim Preserve result(1 To UBound(arrDD), 1 To iPos)
    
89.             result(dic(arrKC(i, 2)), iPos) = arrKC(i, 3)
    
90.             result(1, iPos) = "店面" & arrKC(i, 1) & "的库存"
    
91.             dickc(arrKC(i, 1)) = iPos
    
92.         Else
    
93.             j = dickc(arrKC(i, 1))
    
94.             result(dic(arrKC(i, 2)), j) = result(dic(arrKC(i, 2)), j) + arrKC(i, 3)
    
95.         End If
    
96.     Next
    
97.    
    
98.     '写回表格
    
99.     Range("a1").Resize(UBound(result), UBound(result, 2)) = result
    
100.     '表头
     
101.     Range("a1").Resize(1, 3) = Array("编码", "订货数量", "销量")
     
102.     Set dickc = Nothing
     
103.     Set dic = Nothing
     
104.    
     
105.     t = Timer - t
     
106.     MsgBox "合并合成" & vbCr & "一共费时 " & t & " 秒"
     
107. End Sub
     

复制代码

hwc2ycy

问题在这里分析表 .rar (26.76 KB, 下载次数: 56)

2013-1-3 00:18 上传

点击文件名下载附件

hwc2ycy

把这个文件放到三个文件所在的位置。

hwc2ycy

晕，都0点过了，洗洗睡去。

云影

hwc2ycy 发表于 2013-1-3 00:07
晕，都0点过了，洗洗睡去。

感谢老师，还是感谢老师
REPT("非常",9e+307)&"感谢hwc2ycy老师"

hwc2ycy

1. Sub 合并统计2()
   
2. 'SQL方法
   
3.     Dim arrXL, arrKC, arrDD, arr, item, temp
   
4.     Dim FileXL$, FileKC$, FileDD$
   
5.     Dim result, iPos&, dataSource$
   
6.     Dim i&, j&
   
7.     Dim app As Object
   
8.     Dim t#
   
9.     temp = Array(1, 2, 3)
   
10. 
    
11.     FileXL = "销量.xlsx"
    
12.     FileKC = "库存.xlsx"
    
13.     FileDD = "订单.xlsx"
    
14.     arr = Array(FileDD, FileKC, FileXL)
    
15.     t = Timer
    
16.     'On Error Resume Next
    
17. 
    
18.     For Each item In arr
    
19.         If Len(Dir(ThisWorkbook.Path & "" & item, vbNormal)) = 0 Then
    
20.             MsgBox item & " 不存在", vbCritical
    
21.             Exit Sub
    
22.         End If
    
23.     Next
    
24. 
    
25. 
    
26.     Dim AdoConn As Object, adorst As Object
    
27.     Dim strconn$, strsql$
    
28.     Set AdoConn = CreateObject("ADODB.Connection")
    
29.     strsql = "select * from [sheet1$]"
    
30. 
    
31.     For Each item In arr
    
32.         dataSource = ThisWorkbook.Path & "" & item
    
33. 
    
34.         Select Case Application.Version
    
35.         Case Is = "14.0":
    
36.             strconn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & _
    
37.                       dataSource & ";Extended Properties=""Excel 12.0;HDR=no;imex=1"";"""
    
38.         Case Is = "12.0"
    
39.             strconn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & _
    
40.                       dataSource & ";Extended Properties=""Excel 12.0;HDR=no;imex=1"";"""
    
41.         Case Else
    
42.             strconn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
    
43.                       "Data Source=" & dataSource & "Extended Properties=""Excel 8.0;HDR=no;imex=1"";"
    
44. 
    
45.         End Select
    
46. 
    
47.         On Error Resume Next
    
48.         AdoConn.Open strconn
    
49.         If Err.Number <> 0 Then
    
50.             Err.Clear
    
51.             MsgBox dataSource & " 查询失败", vbCritical
    
52.             Set AdoConn = Nothing
    
53.             Exit Sub
    
54.         End If
    
55. 
    
56.         If AdoConn.State = 1 Then
    
57.             Set adorst = AdoConn.Execute(strsql)
    
58.             temp(i) = adorst.getrows
    
59.             i = i + 1
    
60.             AdoConn.Close
    
61.             'Set adorst = Nothing
    
62.         End If
    
63.     Next
    
64. 
    
65. 
    
66.     Set adorst = Nothing
    
67.     Set AdoConn = Nothing
    
68.    
    
69.     arrXL = WorksheetFunction.Transpose(temp(2))
    
70.     arrKC = WorksheetFunction.Transpose(temp(1))
    
71.     arrDD = WorksheetFunction.Transpose(temp(0))
    
72.     If Err.Number <> 0 Then
    
73.         Err.Clear
    
74.         MsgBox "数据转置失败，请先清除源表格式重来", vbCritical
    
75.         Set AdoConn = Nothing
    
76.         Exit Sub
    
77.     End If
    
78. 
    
79.     ReDim result(1 To UBound(arrDD), 1 To 3)
    
80.     Dim dic As Object, dickc As Object
    
81.     Set dic = CreateObject("scripting.dictionary")
    
82.     Set dickc = CreateObject("scripting.dictionary")
    
83. 
    
84.     iPos = 1
    
85.     '订单统计
    
86.     For i = 2 To UBound(arrDD)
    
87.         If Not dic.exists(arrDD(i, 1)) Then
    
88.             iPos = iPos + 1
    
89.             result(iPos, 1) = arrDD(i, 1)
    
90.             result(iPos, 2) = arrDD(i, 2)
    
91.             dic(arrDD(i, 1)) = iPos
    
92.         Else
    
93.             j = dic(arrDD(i, 1))
    
94.             result(j, 2) = result(j, 2) + arrDD(i, 2)
    
95.         End If
    
96.     Next
    
97. 
    
98.     '销量统计
    
99.     For i = 2 To UBound(arrXL)
    
100.         If dic.exists(arrXL(i, 1)) Then
     
101.             iPos = dic(arrXL(i, 1))
     
102.             result(iPos, 3) = arrDD(i, 2)
     
103.         End If
     
104.     Next
     
105. 
     
106.     '库存统计
     
107.     iPos = UBound(result, 2)
     
108.     For i = 2 To UBound(arrKC)
     
109.         If Not dickc.exists(arrKC(i, 1)) Then
     
110.             iPos = iPos + 1
     
111.             ReDim Preserve result(1 To UBound(arrDD), 1 To iPos)
     
112.             result(dic(arrKC(i, 2)), iPos) = arrKC(i, 3)
     
113.             result(1, iPos) = "店面" & arrKC(i, 1) & "的库存"
     
114.             dickc(arrKC(i, 1)) = iPos
     
115.         Else
     
116.             j = dickc(arrKC(i, 1))
     
117.             result(dic(arrKC(i, 2)), j) = result(dic(arrKC(i, 2)), j) + arrKC(i, 3)
     
118.         End If
     
119.     Next
     
120. 
     
121.     '写回表格
     
122.     Range("a1").Resize(UBound(result), UBound(result, 2)) = result
     
123.     '表头
     
124.     Range("a1").Resize(1, 3) = Array("编码", "订货数量", "销量")
     
125.     Set dickc = Nothing
     
126.     Set dic = Nothing
     
127. 
     
128.     t = Timer - t
     
129.     MsgBox "合并合成" & vbCr & "一共费时 " & t & " 秒"
     
130. End Sub

复制代码

重写了个，这个速度快将近10倍。
你有个数据表格式有问题，你把三个表的格式全清除，就不会报错了。
你把2个代码测试的时候到时贴个图，顺便把数据行有多少也贴下。

feedyu

云影 发表于 2013-1-3 08:33
感谢老师，还是感谢老师
REPT("非常",9e+307)&"感谢hwc2ycy老师"

等"非常"看完,人都老了.....
纯粹不想让人知道答案.!!