如何使用VBA多表求和

adm0795

这几个表每日都会更新数据

feiren228

1. Sub test()
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Dim br(1 To 1, 1 To 5)
   
6.     With Sheets("大货")
   
7.         endrow = .Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
   
8.         arr = .Range("A1:N" & endrow)
   
9.         For i = 3 To UBound(arr)
   
10.             If Not d.exists(arr(i, 1) & "," & arr(i, 10)) Then
    
11.                 d(arr(i, 1) & "," & arr(i, 10)) = ""
    
12.             End If
    
13.         Next
    
14.         For Each k In d.keys
    
15.             For i = 3 To UBound(arr)
    
16.                 If k = arr(i, 1) & "," & arr(i, 10) Then
    
17.                     xp = xp + arr(i, 13): sf = sf + arr(i, 4)
    
18.                 End If
    
19.             Next
    
20.             br(1, 1) = xp: br(1, 2) = sf
    
21.             d(k) = br
    
22.             Erase br
    
23.         Next
    
24.     End With
    
25.     With Sheets("补数")
    
26.         r = .Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
    
27.         arr = .Range("A1:C" & r)
    
28.         For i = 2 To UBound(arr)
    
29.             If Not d.exists(arr(i, 1) & "," & arr(i, 2)) Then
    
30.                 temp = arr(i, 3)
    
31.                 br(1, 3) = temp
    
32.                 d(arr(i, 1) & "," & arr(i, 2)) = br
    
33.                 Erase br
    
34.             Else
    
35.                 tempar = d(arr(i, 1) & "," & arr(i, 2))
    
36.                 temp = arr(i, 3)
    
37.                 tempar(1, 3) = temp
    
38.                 d(arr(i, 1) & "," & arr(i, 2)) = tempar
    
39.             End If
    
40.         Next
    
41.     End With
    
42.     With Sheets("产前打样")
    
43.         r = .Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
    
44.         arr = .Range("A1:C" & r)
    
45.         For i = 2 To UBound(arr)
    
46.             If Not d.exists(arr(i, 1) & "," & arr(i, 2)) Then
    
47.                 temp = arr(i, 3)
    
48.                 br(1, 4) = temp
    
49.                 d(arr(i, 1) & "," & arr(i, 2)) = br
    
50.                 Erase br
    
51.             Else
    
52.                 tempar = d(arr(i, 1) & "," & arr(i, 2))
    
53.                 temp = arr(i, 3)
    
54.                 tempar(1, 4) = temp
    
55.                 d(arr(i, 1) & "," & arr(i, 2)) = tempar
    
56.             End If
    
57.         Next
    
58.     End With
    
59.     With Sheets("工程打样")
    
60.         r = .Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
    
61.         arr = .Range("A1:C" & r)
    
62.         For i = 2 To UBound(arr)
    
63.             If Not d.exists(arr(i, 1) & "," & arr(i, 2)) Then
    
64.                 temp = arr(i, 3)
    
65.                 br(1, 5) = temp
    
66.                 d(arr(i, 1) & "," & arr(i, 2)) = br
    
67.                 Erase br
    
68.             Else
    
69.                 tempar = d(arr(i, 1) & "," & arr(i, 2))
    
70.                 temp = arr(i, 3)
    
71.                 tempar(1, 5) = temp
    
72.                 d(arr(i, 1) & "," & arr(i, 2)) = tempar
    
73.                 Erase br
    
74.             End If
    
75.         Next
    
76.     End With
    
77.     With Sheets("汇总")
    
78.         r = .Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
    
79.         .[a5:H1000].ClearContents
    
80.         .Range("A5").Resize(d.Count) = Application.Transpose(d.keys)
    
81.         .Range("A5:A" & d.Count + 4).TextToColumns Destination:=Range("A5"), Comma:=True
    
82.         .Range("C5").Resize(d.Count, 5) = Application.Transpose(Application.Transpose(d.items))
    
83.         .Range("H5").Resize(d.Count).FormulaR1C1 = "=sum(rc[-5]:rc[-1])"
    
84.     End With
    
85.     Application.DisplayAlerts = True
    
86.     Application.ScreenUpdating = True
    
87. End Sub
    

复制代码

feiren228

附件>>>>>>>>>>>>>>>
如何用VBA求和三个表每日各规格的发料张数.rar (31.29 KB, 下载次数: 25)

2014-12-19 17:06 上传

点击文件名下载附件

adm0795

feiren228 发表于 2014-12-19 17:06
附件>>>>>>>>>>>>>>>

为何汇总的数量不是按日期统计的呢？
比如：10-31各规格发料了多少？
11-1号各规格又发了多少？
11-2号同样，依此类推

feiren228

adm0795 发表于 2014-12-19 18:39
为何汇总的数量不是按日期统计的呢？
比如：10-31各规格发料了多少？
11-1号各规格又发了多少？

不是按日期全部统计出来了吗？不懂你的意思

adm0795

还有个问题想请您帮忙看看，为何我增加了项数，表就运行不了了呢？
出现的错误提示：

运行时错误：13，类型不匹配

adm0795

feiren228 发表于 2014-12-19 20:52
不是按日期全部统计出来了吗？不懂你的意思

还有个问题想请您帮忙看看，为何我从另一个表复制了其它资料到这个表中，表就运行不了了呢？
出现的错误提示：

运行时错误：13，类型不匹配

adm0795

feiren228 发表于 2014-12-19 17:06
附件>>>>>>>>>>>>>>>

不好意思，我现找到原因了，是有几项出现的#N/A的错误值。
但是我运行VBA后，计算出来的结果却不对呢？

今日累计发料张数这列，只需要求和 D至G列的数值。

feiren228

adm0795 发表于 2014-12-19 21:34
还有个问题想请您帮忙看看，为何我从另一个表复制了其它资料到这个表中，表就运行不了了呢？
出现的错 ...

有错误值#N/A，没有加错误处理，再测试
VBA11_v2.zip (119.37 KB, 下载次数: 2)

2014-12-19 22:26 上传

点击文件名下载附件

feiren228

adm0795 发表于 2014-12-19 22:26
不好意思，我现找到原因了，是有几项出现的#N/A的错误值。
但是我运行VBA后，计算出来的结果却不对呢？
...

详见附件>>>>>>>>>>>
VBA11_v3.zip (119.26 KB, 下载次数: 23)

2014-12-19 22:32 上传

点击文件名下载附件