[已解决]高难度的合并并计算

yty773436272

求高手对两张表的数据进行有条件的合并并汇总，具体要求见附件[ 供应.zip (16.08 KB, 下载次数: 27)

2011-12-28 15:52 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

liuguansky

2011-12-28 18:15

1. Sub justtest()
   
2.     Dim D As New Dictionary, Arr, i&, S$, Ar, Ph, Cj$, Sj, K&, ArrR(), j As Byte
   
3.     Ph = [a2]: Cj = [b2]: Sj = [c2]
   
4.     With Worksheets("合并汇总表")
   
5.         Arr = .Range("a3:m" & .Cells(.Rows.Count, 1).End(3).Row).Value
   
6.         For i = 1 To UBound(Arr)
   
7.             S = Arr(i, 1) & Arr(i, 6) & Arr(i, 7)
   
8.             If D.Exists(S) Then
   
9.                 Ar = D(S)
   
10.                 Ar(0) = Arr(i, 9) + CLng(Ar(0))
    
11.                 Ar(1) = Arr(i, 13) + CLng(Ar(1))
    
12.                 D(S) = Ar
    
13.             Else
    
14.                 D.Add S, Array(CLng(Arr(i, 9)), CLng(Arr(i, 13)))
    
15.             End If
    
16.         Next
    
17.     End With
    
18.     With Worksheets("合并调用数据")
    
19.         Arr = .Range("a2:h" & .Cells(.Rows.Count, 1).End(3).Row).Value
    
20.     End With
    
21.     For i = 1 To UBound(Arr)
    
22.         If (Arr(i, 1) = Ph Or Len(Ph) = 0) And _
    
23.             (Arr(i, 6) = Cj Or Len(Cj) = 0) And _
    
24.             (Arr(i, 7) = Sj Or Len(Sj) = 0) Then
    
25.             K = K + 1: ReDim Preserve ArrR(1 To 12, 1 To K)
    
26.             For j = 1 To 8
    
27.                 ArrR(j, K) = Arr(i, j)
    
28.             Next j
    
29.             S = Arr(i, 1) & Arr(i, 6) & Arr(i, 7)
    
30.             If D.Exists(S) Then
    
31.                 ArrR(9, K) = D(S)(0)
    
32.                 ArrR(11, K) = D(S)(1)
    
33.             Else
    
34.                 ArrR(9, K) = 0
    
35.                 ArrR(11, K) = 0
    
36.             End If
    
37.             ArrR(10, K) = ArrR(8, K) - ArrR(9, K)
    
38.             ArrR(12, K) = ArrR(8, K) - ArrR(11, K)
    
39.         End If
    
40.     Next
    
41.     Range("a4:l" & Rows.Count).ClearContents
    
42.     If K > 0 Then Range("a4").Resize(K, 12) = Application.Transpose(ArrR)
    
43.     Set D = Nothing
    
44. End Sub
    

复制代码

是这样的效果吗？
见附件：
供应.rar (20.81 KB, 下载次数: 39)

2011-12-28 18:15 上传

点击文件名下载附件

跳转到最佳答案楼层

fjmxwrs

你是查询表还是汇总表呀？给你弄个汇总的，你看下效果
供应.zip (18.98 KB, 下载次数: 4)

2011-12-28 19:07 上传

点击文件名下载附件

liuguansky

1. Sub justtest()
   
2.     Dim D As New Dictionary, Arr, i&, S$, Ar, Ph, Cj$, Sj, K&, ArrR(), j As Byte
   
3.     Ph = [a2]: Cj = [b2]: Sj = [c2]
   
4.     With Worksheets("合并汇总表")
   
5.         Arr = .Range("a3:m" & .Cells(.Rows.Count, 1).End(3).Row).Value
   
6.         For i = 1 To UBound(Arr)
   
7.             S = Arr(i, 1) & Arr(i, 6) & Arr(i, 7)
   
8.             If D.Exists(S) Then
   
9.                 Ar = D(S)
   
10.                 Ar(0) = Arr(i, 9) + CLng(Ar(0))
    
11.                 Ar(1) = Arr(i, 13) + CLng(Ar(1))
    
12.                 D(S) = Ar
    
13.             Else
    
14.                 D.Add S, Array(CLng(Arr(i, 9)), CLng(Arr(i, 13)))
    
15.             End If
    
16.         Next
    
17.     End With
    
18.     With Worksheets("合并调用数据")
    
19.         Arr = .Range("a2:h" & .Cells(.Rows.Count, 1).End(3).Row).Value
    
20.     End With
    
21.     For i = 1 To UBound(Arr)
    
22.         If (Arr(i, 1) = Ph Or Len(Ph) = 0) And _
    
23.             (Arr(i, 6) = Cj Or Len(Cj) = 0) And _
    
24.             (Arr(i, 7) = Sj Or Len(Sj) = 0) Then
    
25.             K = K + 1: ReDim Preserve ArrR(1 To 12, 1 To K)
    
26.             For j = 1 To 8
    
27.                 ArrR(j, K) = Arr(i, j)
    
28.             Next j
    
29.             S = Arr(i, 1) & Arr(i, 6) & Arr(i, 7)
    
30.             If D.Exists(S) Then
    
31.                 ArrR(9, K) = D(S)(0)
    
32.                 ArrR(11, K) = D(S)(1)
    
33.             Else
    
34.                 ArrR(9, K) = 0
    
35.                 ArrR(11, K) = 0
    
36.             End If
    
37.             ArrR(10, K) = ArrR(8, K) - ArrR(9, K)
    
38.             ArrR(12, K) = ArrR(8, K) - ArrR(11, K)
    
39.         End If
    
40.     Next
    
41.     Range("a4:l" & Rows.Count).ClearContents
    
42.     If K > 0 Then Range("a4").Resize(K, 12) = Application.Transpose(ArrR)
    
43.     Set D = Nothing
    
44. End Sub
    

复制代码

是这样的效果吗？
见附件：
供应.rar (20.81 KB, 下载次数: 39)

2011-12-28 18:15 上传

点击文件名下载附件

yty773436272

fjmxwrs 发表于 2011-12-28 17:45
你是查询表还是汇总表呀？给你弄个汇总的，你看下效果

朋友，不好意思，是这样的效果，不过还要可以查询，我已经把最佳答案给了比你先回帖子的3楼的朋友啦，谢谢你，非常感谢你

fjmxwrs

yty773436272 发表于 2011-12-28 19:21
朋友，不好意思，是这样的效果，不过还要可以查询，我已经把最佳答案给了比你先回帖子的3楼的朋友啦，谢谢 ...

查询可用单元格事件来完成，直接在汇总表的基础上用筛选的方法即可。