求助各位老师：如何修改现代码，即能实现求和，同时能减去对应列的数值

wujunkaim

目前的K-N列的值只实现条件求和，怎么样修改现代码才能在现基础上，还会去减O-R中的值？
附件中有代码说明，也有最终的的效果表。
还请各位老师，帮解答

excel海

你写得太复杂,一个字典应该能搞定

鄂龙蒙

1. Sub 条件求和()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False '工作表里面数据发生变化后False禁止实时刷新，True为默认值表示实时更新数据。
   
6.   Application.DisplayAlerts = False '屏蔽程序执行过程中出现的一些弹出框警告，设置为true就会显示弹出警告。
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   Set d1 = CreateObject("scripting.dictionary")
   
9.   Set d2 = CreateObject("scripting.dictionary")
   
10.   Set d3 = CreateObject("scripting.dictionary")
    
11.   
    
12.   With Worksheets("sheet1")
    
13.     rq1 = .Range("d2")
    
14.     rq2 = .Range("d3")
    
15.   End With
    
16.   
    
17.   With Worksheets("sheet4")
    
18.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
19.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
20.     arr = .Range("a2").Resize(r - 1, c)
    
21.     For i = 1 To UBound(arr)
    
22.       If arr(i, 3) = "A001" Then
    
23.         ReDim brr(1 To 17)
    
24.         brr(1) = arr(i, 7)
    
25.         xm = CStr(arr(i, 7)) '将括号内的数据转换为文本型,也就是string类型
    
26.         d(xm) = brr
    
27.       End If
    
28.     Next
    
29.   End With
    
30.   
    
31.   With Worksheets("sheet2")
    
32.     r = .Cells(.Rows.Count, 3).End(xlUp).Row
    
33.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
34.     arr = .Range("a2").Resize(r - 1, c)
    
35.     For i = 1 To UBound(arr)
    
36.       xm = CStr(arr(i, 3))
    
37.       If d.exists(xm) Then
    
38.         brr = d(xm)
    
39.         n = 0
    
40.         Select Case Mid(arr(i, 10), 2, 2) '取第10列第2个字符开始，取2个字符
    
41.           Case "QQ"
    
42.             n = 1
    
43.           Case "JJ"
    
44.             n = 2
    
45.           Case "XX"
    
46.             n = 3
    
47.           Case "TT"
    
48.             n = 4
    
49.         End Select
    
50.         If n <> 0 Then
    
51.           If Len(arr(i, 17)) < 5 Then '???Len()：得到字符串的长度???
    
52.             brr(n + 1) = brr(n + 1) + 1
    
53.             If arr(i, 16) >= rq1 And arr(i, 16) <= rq2 Then
    
54.               brr(n + 9) = (brr(n + 9) + 1) - .Cells(i, 15)
    
55.             End If
    
56.           Else
    
57.             brr(n + 5) = brr(n + 5) + 1
    
58.           End If
    
59.         End If
    
60.         d(xm) = brr
    
61.       End If
    
62.     Next
    
63.   End With
    
64.   
    
65.   With Worksheets("sheet3")
    
66.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
67.     c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    
68.     arr = .Range("a3").Resize(r - 2, c)
    
69.     For i = 1 To UBound(arr)
    
70.       xm = CStr(arr(i, 7))
    
71.       If d.exists(xm) Then
    
72.         brr = d(xm)
    
73.         n = 0
    
74.         Select Case Mid(arr(i, 6), 2, 2)
    
75.           Case "QQ"
    
76.             n = 1
    
77.           Case "JJ"
    
78.             n = 2
    
79.           Case "XX"
    
80.             n = 3
    
81.           Case "TT"
    
82.             n = 4
    
83.         End Select
    
84.         If n <> 0 Then
    
85.           If Len(arr(i, 8)) < 5 Then
    
86.             If arr(i, 5) >= rq1 And arr(i, 5) <= rq2 Then
    
87.               brr(n + 13) = brr(n + 13) + 1
    
88.             End If
    
89.           End If
    
90.         End If
    
91.         d(xm) = brr
    
92.       End If
    
93.     Next
    
94.   End With
    
95.   
    
96. t = d.items
    
97. For x = 0 To d.Count - 1
    
98.     For i = 0 To 3
    
99.         t(x)(i + 10) = t(x)(i + 10) - t(x)(i + 14)
    
100.     Next
     
101. Next
     
102.   
     
103.   With Worksheets("sheet1")
     
104.     .Range("a7:r" & .Rows.Count).Clear
     
105.     If d.Count > 0 Then
     
106.       With .Range("b7").Resize(d.Count, UBound(brr))
     
107. '        .Value = Application.Transpose(Application.Transpose(d.items))
     
108.         .Value = Application.Transpose(Application.Transpose(t))
     
109.         .Borders.LineStyle = xlContinuous '区域单元格设置线
     
110.       End With
     
111.     End If
     
112.     .Select
     
113.   End With
     
114.   
     
115. End Sub

复制代码