VBA多条件求和汇总

alexagain

求助多条件求和汇总，盼老师们指点：
目的：1、清空黄色区域，2、多条件汇总填入对应单元格（详见附件）。
1、清空黄色区域的代码已完成。
2、多条件求和代码写不对，求助解决。
3、求和的三个条件：日期、产品名称、工序号。

seele012002

看看是不是这样？

1. Sub qqq()                                  '多条件汇总
   
2.    Dim d, ar, br, cr, dr
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     ar = Sheet1.Range("A1").CurrentRegion
   
5.     br = Sheet2.[e2:ab63]: cr = Sheet2.[a2:a63]: dr = Sheet2.[b2:b63]
   
6.     For i = 2 To UBound(ar)
   
7.         s = ar(i, 1) & ar(i, 2) & ar(i, 3)
   
8.         d(s) = d(s) + ar(i, 4)
   
9.         If ar(i, 2) = "" Then
   
10.             s = ar(i, 1) & ar(i, 2) & ar(i, 3)
    
11.             d(s) = d(s) + ar(i, 4)
    
12.         End If
    
13.     Next
    
14.     For i = 3 To UBound(br)
    
15.         For j = 2 To UBound(br, 2) Step 2
    
16.             br(i, j) = d(br(1, j - 1) & cr(i, 1) & dr(i, 1))
    
17.         Next
    
18.     Next
    
19.     Sheet2.[e2:ab63] = br
    
20. End Sub

复制代码

不知道为什么

1. Sub qiuhe()
   
2.     Application.ScreenUpdating = False
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     arr = [a2].CurrentRegion
   
5.     brr = Sheets("日报表").[a1].CurrentRegion
   
6.     For i = 4 To UBound(arr)
   
7.         For j = 5 To UBound(arr, 2)
   
8.             If Len(arr(2, j)) > 0 Then
   
9.                 ms = DateValue(arr(2, j)) & arr(i, 1) & arr(i, 2)
   
10.                 dic(ms) = i & "|" & j + 1
    
11.             End If
    
12.         Next j
    
13.     Next i
    
14.     For i = 2 To UBound(brr)
    
15.         ms = DateValue(brr(i, 1)) & brr(i, 2) & brr(i, 3)
    
16.         If dic.exists(ms) Then
    
17.             x = Val(Split(dic(ms), "|")(0))
    
18.             y = Val(Split(dic(ms), "|")(1))
    
19.             Cells(x, y) = Cells(x, y) + brr(i, 4)
    
20.         End If
    
21.     Next i
    
22.     Application.ScreenUpdating = True
    
23. End Sub

复制代码

代码供参考

shi353

Sub step1()           'clear yellow area  
Application.ScreenUpdating = False
Dim rng As Range
For i = 1 To 150 Step 2
    If i = 1 Then
        Set rng = Range(Cells(4, i + 5), Cells(63, i + 5))
    Else
        Set rng = Application.Union(rng, Range(Cells(4, i + 5), Cells(63, i + 5)))
    End If
Next
rng.Select
Selection.ClearContents
Application.ScreenUpdating = True
End Sub

Sub step2()           'calculate yellow area sum  
ar = Sheet1.Range("A1").CurrentRegion
Set B = Sheet2.[e2:ab2]
R = Sheet2.[A65000].End(3).Row
'---------------------------------
For i = 1 To B.Cells.Count Step 2
    For j = 1 To R - 3
        C1 = B.Cells(i)
        C2 = Sheet2.Cells(j + 3, 1)
        C3 = Sheet2.Cells(j + 3, 2)
        B.Cells(i).Offset(j + 1).Offset(, 1).Value = CCheck(ar, C1, C2, C3, i, j)
    Next
Next
End Sub

Function CCheck(ar, C1, C2, C3, i, j)
    For k = 1 To UBound(ar)
        If ar(k, 1) = C1 And ar(k, 2) = C2 And ar(k, 3) = C3 Then
            S = S + ar(k, 4)
        End If
    Next
    CCheck = S
End Function

lsc900707

求和代码修改一下就好了：

1. Sub qqq()                                  '多条件汇总
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     ar = Sheet1.Range("A1").CurrentRegion
   
4.     br = [a1].CurrentRegion
   
5.     For i = 2 To UBound(ar)
   
6.         s = ar(i, 1) & ar(i, 2) & ar(i, 3)
   
7.         d(s) = d(s) + ar(i, 4)
   
8.     Next
   
9.     For i = 4 To UBound(br)
   
10.         For j = 5 To UBound(br, 2) - 1 Step 2
    
11.             s = br(2, j) & br(i, 1) & br(i, 2)
    
12.             If d.exists(s) Then br(i, j + 1) = d(s)
    
13.         Next
    
14.     Next
    
15.    [a1].CurrentRegion = br
    
16. End Sub
    

复制代码

lsc900707

附件供参考：

alexagain

非常感谢各位老师的帮助，所有代码都测试过，都正确。谢谢！
这方面，我还要更加努力学习。

lsc900707

alexagain 发表于 2018-5-16 12:40
非常感谢各位老师的帮助，所有代码都测试过，都正确。谢谢！
这方面，我还要更加努力学习。

回帖要点对方的帖子下方的“回复”，这样就知道你有反馈。
可以尝试给帮助者“评分”来表示谢意！

alexagain

lsc900707 发表于 2018-5-16 18:37
回帖要点对方的帖子下方的“回复”，这样就知道你有反馈。
可以尝试给帮助者“评分”来表示谢意！

知道了，谢谢指导！

alexagain

seele012002 发表于 2018-5-16 00:07
看看是不是这样？

感谢帮助，效果非常满意，谢谢！