Sub abxy()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Const wsTonghop As String = "Tonghop*"
Dim ws As Worksheet, lR As Long, r As Long, i As Long
Dim DL(), Ma As String, m As Long, tmpMa, iMa
Dim sArr(1 To 10 ^ 6, 1 To 4)
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name Like wsTonghop Then
lR = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
If lR = 1 Then GoTo 1
DL = ws.Range("C2:H" & lR): lR = UBound(DL, 1)
For r = 1 To lR
If DL(r, 1) <> Empty And DL(r, 2) <> Empty Then
If DL(r, 3) <> Empty And DL(r, 6) <> Empty Then
Ma = DL(r, 1): m = Month(CDate(DL(r, 3)))
If IsNumeric(Ma) Then
i = i + 1
sArr(i, 1) = CLng(Ma): sArr(i, 2) = DL(r, 2)
sArr(i, 3) = m: sArr(i, 4) = DL(r, 6)
If VBA.UCase(DL(r, 6)) Like "SPECIAL" Then sArr(i, 4) = 6
Else
tmpMa = Split(Replace(Ma, " ", ""), "&")
For Each iMa In tmpMa
If i > 10 ^ 6 Then GoTo 2:
i = i + 1
sArr(i, 1) = CLng(iMa): sArr(i, 2) = DL(r, 2) / (UBound(tmpMa) + 1)
sArr(i, 3) = m: sArr(i, 4) = DL(r, 6)
If VBA.UCase(DL(r, 6)) Like "SPECIAL" Then sArr(i, 4) = 6
Next iMa
End If
End If
End If
Next r
End If
1:
Next ws
2:
If i Then
Dim MH(), maxMH As Long, j As Long, k As Long, iDG As Long
[COLOR=#0000ff]MH = Sheets("Tonghop2").Range("C7:C5592").Value[/COLOR]: maxMH = UBound(MH, 1)
ReDim KQ(1 To maxMH, 1 To (13 * 6 + 5))
For j = 1 To maxMH
For r = 1 To i '
If sArr(r, 1) = MH(j, 1) Then
iDG = sArr(r, 4)
iDG = (iDG - 1) * 14 + 1
KQ(j, iDG + sArr(r, 3)) = KQ(j, iDG + sArr(r, 3)) + sArr(r, 2)
End If
Next r
For k = 1 To 6
KQ(j, (k - 1) * 14 + 1) = MH(j, 1)
Next k
Next j
End If
Sheets("Tonghop2").Range("C7").Resize(maxMH, UBound(KQ, 2)) = KQ
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
)
( ...
