[已解决]双条件求两列差值

amzxfgh9632

双条件提取不重复值及日期（变横 向）求差值。且生成合计数

双条件汇总求差.zip (16.31 KB, 下载次数: 11)

2017-8-1 08:07 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

windyjw007

2017-8-1 08:46

试试{:2912:}
P.S. 生成的数据没有排序{:2312:}

1. Sub hz()
   
2.     Dim dr As Object, dc As Object
   
3.     Dim ar, br(1 To 10000, 1 To 1000)
   
4.     Dim sr As String
   
5.     Dim i As Long, j As Long, k As Long, m As Long, n As Long
   
6.     Dim rw As Long, cl As Long
   
7.     Dim hj As Double
   
8.     br(1, 1) = "客户": br(1, 2) = "品名"
   
9.     j = 1: k = 2
   
10.     Set dr = CreateObject("scripting.dictionary")
    
11.     Set dc = CreateObject("scripting.dictionary")
    
12.     ar = Cells(1, 1).CurrentRegion
    
13.     For i = 2 To UBound(ar)
    
14.         sr = ar(i, 2) & vbTab & ar(i, 3)
    
15.         If Not dr.exists(sr) Then
    
16.             j = j + 1
    
17.             dr.Add sr, j
    
18.             br(j, 1) = ar(i, 2)
    
19.             br(j, 2) = ar(i, 3)
    
20.         End If
    
21.         rw = dr(sr)
    
22.         If Not dc.exists(ar(i, 1)) Then
    
23.             k = k + 1
    
24.             dc.Add ar(i, 1), k
    
25.             br(1, k) = ar(i, 1)
    
26.         End If
    
27.         cl = dc(ar(i, 1))
    
28.         br(rw, cl) = br(rw, cl) + ar(i, 5) - ar(i, 4)
    
29.     Next i
    
30.     br(j + 1, 1) = "合计": br(1, k + 1) = "合计"
    
31.     For m = 2 To j
    
32.         For n = 3 To k
    
33.             br(m, k + 1) = br(m, k + 1) + br(m, n)
    
34.             br(j + 1, n) = br(j + 1, n) + br(m, n)
    
35.             hj = hj + br(m, n)
    
36.         Next n
    
37.     Next m
    
38.     br(j + 1, k + 1) = hj
    
39.     With Cells(1, 7)
    
40.         .Resize(Rows.Count, k + 1).ClearContents
    
41.         .Resize(j + 1, k + 1) = br
    
42.     End With
    
43. End Sub
    

复制代码

跳转到最佳答案楼层

windyjw007

试试{:2912:}
P.S. 生成的数据没有排序{:2312:}

1. Sub hz()
   
2.     Dim dr As Object, dc As Object
   
3.     Dim ar, br(1 To 10000, 1 To 1000)
   
4.     Dim sr As String
   
5.     Dim i As Long, j As Long, k As Long, m As Long, n As Long
   
6.     Dim rw As Long, cl As Long
   
7.     Dim hj As Double
   
8.     br(1, 1) = "客户": br(1, 2) = "品名"
   
9.     j = 1: k = 2
   
10.     Set dr = CreateObject("scripting.dictionary")
    
11.     Set dc = CreateObject("scripting.dictionary")
    
12.     ar = Cells(1, 1).CurrentRegion
    
13.     For i = 2 To UBound(ar)
    
14.         sr = ar(i, 2) & vbTab & ar(i, 3)
    
15.         If Not dr.exists(sr) Then
    
16.             j = j + 1
    
17.             dr.Add sr, j
    
18.             br(j, 1) = ar(i, 2)
    
19.             br(j, 2) = ar(i, 3)
    
20.         End If
    
21.         rw = dr(sr)
    
22.         If Not dc.exists(ar(i, 1)) Then
    
23.             k = k + 1
    
24.             dc.Add ar(i, 1), k
    
25.             br(1, k) = ar(i, 1)
    
26.         End If
    
27.         cl = dc(ar(i, 1))
    
28.         br(rw, cl) = br(rw, cl) + ar(i, 5) - ar(i, 4)
    
29.     Next i
    
30.     br(j + 1, 1) = "合计": br(1, k + 1) = "合计"
    
31.     For m = 2 To j
    
32.         For n = 3 To k
    
33.             br(m, k + 1) = br(m, k + 1) + br(m, n)
    
34.             br(j + 1, n) = br(j + 1, n) + br(m, n)
    
35.             hj = hj + br(m, n)
    
36.         Next n
    
37.     Next m
    
38.     br(j + 1, k + 1) = hj
    
39.     With Cells(1, 7)
    
40.         .Resize(Rows.Count, k + 1).ClearContents
    
41.         .Resize(j + 1, k + 1) = br
    
42.     End With
    
43. End Sub
    

复制代码

amzxfgh9632

谢谢，测试完全正确