多个时间区间里面的单独判断

ymsh1234

         要求：每天三个仓库都有货物进出，需要使用VBA找到入库数量超过80公斤的天数。第41行就是手工计算出来正确的答案。
         在附件里面我自己写了一个版本的VBA，但是结果不是我要的，但是又不知道错在什么地方，请大神指点一下。      

microyip

你的正确答案也不对，好吧？

1. Sub 统计()
   
2.     Dim vData As Variant, nRow As Integer, nCol As Integer
   
3.    
   
4.     nRow = [A1].CurrentRegion.Rows.Count
   
5.     vData = [F2].Resize(nRow - 1, 4)
   
6.     For nRow = 1 To UBound(vData)
   
7.         For nCol = 1 To UBound(vData, 2)
   
8.             vData(1, nCol) = -vData(1, nCol) * (nRow > 1) - 1 * (vData(nRow, nCol) > 80)
   
9.         Next
   
10.     Next
    
11.     [F42:H42] = vData
    
12. End Sub

复制代码

microyip

附上附件以供参考

chen7806

时间格式是文本，计算机无法确定时间段。

chxw68

修改的楼主程序：

1. Sub cs()
   
2.   Dim a, B, p, q, r, s, t As Integer
   
3.   Dim brr(1 To 3) As Integer
   
4.   For a = 2 To Sheet3.[C65536].End(3).Row
   
5.     For p = a To Sheet3.[C65536].End(3).Row
   
6.       If Sheet3.Cells(p, 1) <> Sheet3.Cells(p + 1, 1) Then
   
7.         Exit For
   
8.       End If
   
9.     Next
   
10.    
    
11.     For j = 6 To 8
    
12.       For q = a To p
    
13.         If Sheet3.Cells(q, j) > 80 Then
    
14.           brr(j - 5) = brr(j - 5) + 1
    
15.           Exit For
    
16.         End If
    
17.       Next
    
18.     Next
    
19.     a = p
    
20.   Next
    
21.   Sheet3.Cells(40, 6).Resize(1, 3) = brr
    
22. End Sub
    

复制代码

chxw68

使用字典的程序：

1. Sub test2()
   
2.   Dim r%, i%
   
3.   Dim arr, brr() As Integer
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet3")
   
7.     r = .Cells(1, 1).End(xlDown).Row
   
8.     arr = .Range("a2:h" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Not d.exists(arr(i, 1)) Then
    
11.         ReDim brr(6 To 8)
    
12.       Else
    
13.         brr = d(arr(i, 1))
    
14.       End If
    
15.       For j = 6 To 8
    
16.         If arr(i, j) > 80 Then
    
17.           brr(j) = 1
    
18.         End If
    
19.       Next
    
20.       d(arr(i, 1)) = brr
    
21.     Next
    
22.     crr = Application.Transpose(Application.Transpose(d.items))
    
23.     ReDim drr(1 To 3)
    
24.     For j = 1 To UBound(crr, 2)
    
25.       drr(j) = Application.Sum(Application.Index(crr, 0, j))
    
26.     Next
    
27.     .Range("f39").Resize(1, 3) = drr
    
28.   End With
    
29. End Sub
    

复制代码

chxw68

不用字典的程序

1. Sub test3()
   
2.   Dim r%, i%
   
3.   Dim arr, brr%(), crr%(), zrr()
   
4.   With Worksheets("sheet3")
   
5.     r = .Cells(1, 1).End(xlDown).Row
   
6.     arr = .Range("a2:h" & r)
   
7.     m = 0
   
8.     xm = ""
   
9.     For i = 1 To UBound(arr)
   
10.       If xm <> arr(i, 1) Then
    
11.         m = m + 1
    
12.         ReDim Preserve zrr(1 To 2, 1 To m)
    
13.         zrr(1, m) = i
    
14.         zrr(2, m) = i
    
15.         xm = arr(i, 1)
    
16.       Else
    
17.         zrr(2, m) = i
    
18.       End If
    
19.     Next
    
20.     ReDim brr(1 To 3)
    
21.     For k = 1 To UBound(zrr, 2)
    
22.       ReDim crr(1 To 3)
    
23.       For j = 6 To 8
    
24.         For i = zrr(1, k) To zrr(2, k)
    
25.           If arr(i, j) > 80 Then
    
26.             crr(j - 5) = 1
    
27.           End If
    
28.         Next
    
29.       Next
    
30.       For j = 1 To 3
    
31.         brr(j) = brr(j) + crr(j)
    
32.       Next
    
33.     Next
    
34.     .Range("f39").Resize(1, 3) = brr
    
35.   End With
    
36. End Sub
    
37. 
    

复制代码

chxw68

仅供楼主参考。