[已解决]vba条件计数求助

云影

要求已写在附件，谢谢
刚才模拟结果有误，已更新

最佳答案

月排行榜 / 总排行榜

妞叫七七

2013-6-19 15:44

1. Sub tongjizu()
   
2. Dim arr, arr1
   
3. Dim d As Object, x, y
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d1 = CreateObject("scripting.dictionary")
   
6. arr = Range("b2:e21257")
   
7. arr1 = Range("g2:g13")
   
8. For x = 1 To 3
   
9.     For y = 1 To UBound(arr)
   
10.       If arr(y, 2) = arr1(x * 4 - 3, 1) Then
    
11.          If arr(y + 1, 2) = arr1(x * 4 - 2, 1) Then
    
12.             If arr(y + 2, 2) = arr1(x * 4 - 1, 1) Then
    
13.                If arr(y + 3, 2) = arr1(x * 4, 1) Then
    
14.                  y = y + 3
    
15.                  MsgBox y
    
16.                  d(arr(y, 1)) = d(arr(y, 1)) + 1
    
17.                  d1(arr(y, 4)) = d1(arr(y, 4)) + 1
    
18.                  GoTo 100
    
19.                End If
    
20.             End If
    
21.          End If
    
22.       End If
    
23. 100:
    
24.     Next y
    
25. Next x
    
26. Range("i2").Resize(d.Count) = Application.Transpose(d.keys)
    
27. Range("j2").Resize(d.Count) = Application.Transpose(d.items)
    
28. Range("L2").Resize(d1.Count) = Application.Transpose(d1.keys)
    
29. Range("m2").Resize(d1.Count) = Application.Transpose(d1.items)
    
30. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

要求所有的编号在同一组的才算？

妞叫七七

我写了个程序,怎么结果只有甲有3组,其他的一个也没有

妞叫七七

1. Sub tongjizu()
   
2. Dim arr, arr1
   
3. Dim d As Object, x, y
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Range("b2:c21257")
   
6. arr1 = Range("g2:g13")
   
7. For x = 1 To 3
   
8.     For y = 1 To UBound(arr)
   
9.       If arr(y, 2) = arr1(x * 4 - 3, 1) Then
   
10.          If arr(y + 1, 2) = arr1(x * 4 - 2, 1) Then
    
11.             If arr(y + 2, 2) = arr1(x * 4 - 1, 1) Then
    
12.                If arr(y + 3, 2) = arr1(x * 4, 1) Then
    
13.                  y = y + 3
    
14.                  d(arr(y, 1)) = d(arr(y, 1)) + 1
    
15.                  GoTo 100
    
16.                End If
    
17.             End If
    
18.          End If
    
19.       End If
    
20. 100:
    
21.     Next y
    
22. Next x
    
23. Range("i2").Resize(d.Count) = Application.Transpose(d.keys)
    
24. Range("j2").Resize(d.Count) = Application.Transpose(d.items)
    
25. End Sub
    

复制代码

云影

hwc2ycy 发表于 2013-6-19 13:41
要求所有的编号在同一组的才算？

是的老师                                             

云影

妞叫七七 发表于 2013-6-19 14:14

谢谢您的帮助，可能是我附件有问题已在5楼更新附件麻烦您在看一下，谢谢

妞叫七七

运行了一下,代码应该没错,只是符合条件的结果太少了

云影

妞叫七七 发表于 2013-6-19 15:22
运行了一下,代码应该没错,只是符合条件的结果太少了

麻烦您，还有经办人列

妞叫七七

1. Sub tongjizu()
   
2. Dim arr, arr1
   
3. Dim d As Object, x, y
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d1 = CreateObject("scripting.dictionary")
   
6. arr = Range("b2:e21257")
   
7. arr1 = Range("g2:g13")
   
8. For x = 1 To 3
   
9.     For y = 1 To UBound(arr)
   
10.       If arr(y, 2) = arr1(x * 4 - 3, 1) Then
    
11.          If arr(y + 1, 2) = arr1(x * 4 - 2, 1) Then
    
12.             If arr(y + 2, 2) = arr1(x * 4 - 1, 1) Then
    
13.                If arr(y + 3, 2) = arr1(x * 4, 1) Then
    
14.                  y = y + 3
    
15.                  MsgBox y
    
16.                  d(arr(y, 1)) = d(arr(y, 1)) + 1
    
17.                  d1(arr(y, 4)) = d1(arr(y, 4)) + 1
    
18.                  GoTo 100
    
19.                End If
    
20.             End If
    
21.          End If
    
22.       End If
    
23. 100:
    
24.     Next y
    
25. Next x
    
26. Range("i2").Resize(d.Count) = Application.Transpose(d.keys)
    
27. Range("j2").Resize(d.Count) = Application.Transpose(d.items)
    
28. Range("L2").Resize(d1.Count) = Application.Transpose(d1.keys)
    
29. Range("m2").Resize(d1.Count) = Application.Transpose(d1.items)
    
30. End Sub

复制代码