然后d4的item应该和d1一样的,为什么d4出现的确是startT和endT的? 下面黄色句子出现下标越界错误Private Sub CommandButton1_Click()
Dim i As Integer, j As Integer, a As Integer, b As Integer
Dim arrA(1 To 60) As Double, arrB(1 To 60) As Double, arr, arr1, arr2
Dim arrC(1 To 60) As Double
Dim d1 As New Dictionary, d2 As New Dictionary
Dim d3 As New Dictionary
Dim d4 As New Dictionary
'Dim p As IntegerDim StartT As Date, endT As Date Application.DisplayAlerts = False
Application.ScreenUpdating = False
arr = Sheets("Jan").Range("A5:AJ" & Sheets("Jan").Range("A65536").End(xlUp).Row)
arr1 = Sheets("Jan").Range("AK2:AM" & Sheets("Jan").Range("AK2").End(xlDown).Row)
arr2 = Sheets("Jan").Range("A5:AF" & Sheets("Jan").Range("A65536").End(xlUp).Row)Set d1 = New Dictionary
Set d2 = New Dictionary
Set d3 = New Dictionary
Set d4 = New DictionaryFor i = 2 To UBound(arr)
If Not d1.Exists(arr(i, 1)) Then
d1(arr(i, 1)) = i
End If
NextFor i = 2 To UBound(arr1)
If Not d2.Exists(arr1(i, 1)) Then
d2(arr1(i, 1)) = i
End If
NextFor i = 2 To UBound(arr2)
If Not d4.Exists(arr2(i, 1)) Then
d1(arr2(i, 1)) = i
End If
NextFor i = 1 To 6
If Not d2.Exists(arr1(i, 3)) Then
d3(arr1(i, 3)) = 0
End If
Next StartT = Cells(17, 37)
endT = Cells(17, 38)
For j = 2 To UBound(arr, 2)
For i = d1(StartT) To d1(endT)
If IsNumeric(arr(i, j)) Then
If Not d2.Exists(arr(i, 1)) And Not Weekday(arr(i, 1)) = 1 And Not Weekday(arr(i, 1)) = 7 Then
arrA(j) = arrA(j) + arr(i, j) + 8
arrB(j) = arrB(j) + arr(i, j)
Else
arrA(j) = arrA(j) + arr(i, j)
arrB(j) = arrB(j) + arr(i, j)
End If
Else
If d3.Exists(arr(i, j)) Then
d3(arr(i, j)) = d3(arr(i, j)) + 1
End If
End If
Next
Next
For j = 2 To UBound(arr2, 2)
For i = d4(StartT) To d4(endT)
If IsNumeric(arr2(i, j)) Then If Not d2.Exists(arr2(i, 1)) And Not Weekday(arr2(i, 1)) = 1 And Not Weekday(arr2(i, 1)) = 7 Then
arrC(j) = arrC(j) + arr2(i, j) + 8
Else
arrC(j) = arrC(j) + arr2(i, j)
End If
End If
Next
Next Cells(17, 40) = Application.Sum(arrC())
Cells(15, 40) = Application.Max(arrB())
Cells(15, 39) = Application.Sum(arrA())
Cells(2, 40).Resize(d3.Count) = Application.Transpose(d3.Items)
Set arr = Nothing
Set arr2 = Nothing
Set arr1 = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Dim i As Integer, j As Integer, a As Integer, b As Integer
Dim arrA(1 To 60) As Double, arrB(1 To 60) As Double, arr, arr1, arr2
Dim arrC(1 To 60) As Double
Dim d1 As New Dictionary, d2 As New Dictionary
Dim d3 As New Dictionary
Dim d4 As New Dictionary
'Dim p As IntegerDim StartT As Date, endT As Date Application.DisplayAlerts = False
Application.ScreenUpdating = False
arr = Sheets("Jan").Range("A5:AJ" & Sheets("Jan").Range("A65536").End(xlUp).Row)
arr1 = Sheets("Jan").Range("AK2:AM" & Sheets("Jan").Range("AK2").End(xlDown).Row)
arr2 = Sheets("Jan").Range("A5:AF" & Sheets("Jan").Range("A65536").End(xlUp).Row)Set d1 = New Dictionary
Set d2 = New Dictionary
Set d3 = New Dictionary
Set d4 = New DictionaryFor i = 2 To UBound(arr)
If Not d1.Exists(arr(i, 1)) Then
d1(arr(i, 1)) = i
End If
NextFor i = 2 To UBound(arr1)
If Not d2.Exists(arr1(i, 1)) Then
d2(arr1(i, 1)) = i
End If
NextFor i = 2 To UBound(arr2)
If Not d4.Exists(arr2(i, 1)) Then
d1(arr2(i, 1)) = i
End If
NextFor i = 1 To 6
If Not d2.Exists(arr1(i, 3)) Then
d3(arr1(i, 3)) = 0
End If
Next StartT = Cells(17, 37)
endT = Cells(17, 38)
For j = 2 To UBound(arr, 2)
For i = d1(StartT) To d1(endT)
If IsNumeric(arr(i, j)) Then
If Not d2.Exists(arr(i, 1)) And Not Weekday(arr(i, 1)) = 1 And Not Weekday(arr(i, 1)) = 7 Then
arrA(j) = arrA(j) + arr(i, j) + 8
arrB(j) = arrB(j) + arr(i, j)
Else
arrA(j) = arrA(j) + arr(i, j)
arrB(j) = arrB(j) + arr(i, j)
End If
Else
If d3.Exists(arr(i, j)) Then
d3(arr(i, j)) = d3(arr(i, j)) + 1
End If
End If
Next
Next
For j = 2 To UBound(arr2, 2)
For i = d4(StartT) To d4(endT)
If IsNumeric(arr2(i, j)) Then If Not d2.Exists(arr2(i, 1)) And Not Weekday(arr2(i, 1)) = 1 And Not Weekday(arr2(i, 1)) = 7 Then
arrC(j) = arrC(j) + arr2(i, j) + 8
Else
arrC(j) = arrC(j) + arr2(i, j)
End If
End If
Next
Next Cells(17, 40) = Application.Sum(arrC())
Cells(15, 40) = Application.Max(arrB())
Cells(15, 39) = Application.Sum(arrA())
Cells(2, 40).Resize(d3.Count) = Application.Transpose(d3.Items)
Set arr = Nothing
Set arr2 = Nothing
Set arr1 = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
解决方案 »
免费领取超大流量手机卡,每月29元包185G流量+100分钟通话, 中国电信官方发货