Option Explicit
Sub LapCDPS()
'====SEALAND: GIAIPHAPEXCEL=====
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Dim MaxCls, Tm, Kq(), Ch(1 To 3), Tn, Dn, ID, i, j, n
Application.ScreenUpdating = False
Tm = Sheet2.Range("A4:E" & Sheet2.[A65536].End(3).Row)
Tn = Sheet3.[G2]: Dn = Sheet3.[G3]
'Dua bang MaTK va so du vao mang
For i = 1 To UBound(Tm, 1)
If Not Dic.Exists(Tm(i, 1)) Then
ID = ID + 1
Dic.Add IIf(IsNumeric(Tm(i, 1)), CStr(Tm(i, 1)), Trim(Tm(i, 1))), ID
ReDim Preserve Kq(1 To 9, 1 To ID)
Kq(1, ID) = Tm(i, 1)
Kq(2, ID) = Tm(i, 2)
Kq(3, ID) = Tm(i, 4)
Kq(4, ID) = Tm(i, 5)
Kq(9, ID) = Tm(i, 3)
If MaxCls < Tm(i, 3) Then MaxCls = Tm(i, 3)
End If
Next
'Tap hop phat sinh trong ky
Tm = Sheet1.Range("D3:L" & Sheet1.[D65536].End(3).Row)
For i = 1 To UBound(Tm, 1)
If Tm(i, 1) < Tn Then
ID = Dic.Item(Tm(i, 7))
Kq(3, ID) = Kq(3, ID) + Tm(i, 9)
ID = Dic.Item(Tm(i, 8))
Kq(4, ID) = Kq(4, ID) + Tm(i, 9)
ElseIf Tm(i, 1) > Tn - 1 And Tm(i, 1) < Dn + 1 Then
ID = Dic.Item(Tm(i, 7))
Kq(5, ID) = Kq(5, ID) + Tm(i, 9)
ID = Dic.Item(Tm(i, 8))
Kq(6, ID) = Kq(6, ID) + Tm(i, 9)
End If
Next
'Tinh so du
For i = 1 To UBound(Kq, 2)
Kq(7, i) = IIf(Kq(3, i) - Kq(4, i) + Kq(5, i) - Kq(6, i) > 0, Kq(3, i) - Kq(4, i) + Kq(5, i) - Kq(6, i), 0)
Kq(8, i) = IIf(Kq(4, i) - Kq(3, i) + Kq(6, i) - Kq(5, i) > 0, Kq(4, i) - Kq(3, i) + Kq(6, i) - Kq(5, i), 0)
Next
'Tong cong bao cao
ReDim Preserve Kq(1 To 9, 1 To UBound(Kq, 2) + 1)
Kq(2, UBound(Kq, 2)) = Space(30) & "Tong cong :"
For i = 1 To UBound(Kq, 2) - 1
For j = 3 To 8
Kq(j, UBound(Kq, 2)) = Kq(j, UBound(Kq, 2)) + Kq(j, i)
Next
Next
'Tong hop cho TK me
Do
MaxCls = MaxCls - 1
If MaxCls = 0 Then Exit Do
For i = 1 To UBound(Kq, 2)
If Kq(9, i) = MaxCls Then
For j = 1 To UBound(Kq, 2)
If Kq(9, j) = MaxCls + 1 And InStr(1, Kq(1, j), Kq(1, i)) = 1 Then
For n = 3 To 8
Kq(n, i) = Kq(n, i) + Kq(n, j)
Next
End If
Next
End If
Next
Loop
'Don co du lieu
j = 0
For i = 1 To UBound(Kq, 2)
If Kq(3, i) <> 0 Or Kq(4, i) <> 0 Or Kq(5, i) <> 0 Or Kq(6, i) <> 0 Then
j = j + 1
For n = 1 To 9
Kq(n, j) = Kq(n, i)
Next
Select Case Kq(9, j)
Case Is = 1
Ch(1) = Ch(1) & IIf(Ch(1) = "", "", ",") & "A" & 10 + j & ":H" & 10 + j
Case Is = 2
Ch(2) = Ch(2) & IIf(Ch(2) = "", "", ",") & "A" & 10 + j & ":H" & 10 + j
Case Else
Ch(3) = Ch(3) & IIf(Ch(3) = "", "", ",") & "A" & 10 + j & ":H" & 10 + j
End Select
End If
Next
Sheet3.[A11:H2000].Clear
Sheet3.[A11:H11].Resize(j) = WorksheetFunction.Transpose(Kq)
'Dinh dang bao cao
With Sheet3.Range(Ch(1))
.Font.FontStyle = "Bold"
.Interior.ColorIndex = 37
End With
With Sheet3.Range(Ch(2))
.Font.ColorIndex = 5
.Font.FontStyle = "Bold"
.Interior.ColorIndex = 0
End With
With Sheet3.Range(Ch(3))
.Font.FontStyle = "Italic"
.Font.ColorIndex = 53
.Interior.ColorIndex = 0
End With
Sheet3.[C11].Resize(j, 6).NumberFormat = "#,##0"
With Sheet3.[A11].Resize(j, 8)
.Font.Name = "Time New Roman"
.Borders.Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlHairline
End With
With Sheet3.Cells(j + 10, 1).Resize(, 8)
.Borders.Weight = xlThin
.Font.FontStyle = "Bold"
.Font.ColorIndex = 2
.Font.Size = 12
.Interior.ColorIndex = 11
End With
Application.ScreenUpdating = True
Set Dic = Nothing
End Sub
