Option Explicit
Option Base 1
Dim endR As Long, iR As Long, iC As Long, fR As Long
Dim solan As Long, s As Long, i As Long, iNam As Long, iMua As Long
Dim wf As WorksheetFunction
Dim sWell As String, Tmp As String, sNamMua As String, myRng As Range
Dim Arr, ArrCT, ArrKQ, ArrMua(), ArrForm()
Sub TaoForm()
Set wf = WorksheetFunction
ArrMua = Array("K", "M")
With Sheets("FormMau")
sWell = .[D2]
End With
With Sheets("Data")
endR = .Cells(65000, 1).End(xlUp).Row
Set myRng = .Range("A2:A" & endR)
End With
solan = wf.CountIf(myRng, sWell)
If solan = 0 Then GoTo bien
With Sheets("Data")
endR = .Cells(65000, 1).End(xlUp).Row
fR = wf.Match(sWell, myRng, 0)
Set myRng = .Range("A2").Offset(fR - 1, 0).Resize(solan, 22)
Arr = .Range("A2").Offset(fR - 1, 0).Resize(solan, 3).Value
ArrCT = .Range("A2").Offset(fR - 1, 3).Resize(solan, 19).Value 'ct so lieu'
End With
ReDim ArrKQ(1 To 19, 1 To 21)
'cot thanh dong
For iC = 1 To UBound(ArrCT, 2) 'theo cot'
solan = 0: s = 0
For iNam = 1 To 9
For iMua = 1 To UBound(ArrMua)
s = s + 1
sNamMua = 2000 + iNam & "/" & ArrMua(iMua)
For iR = 1 To UBound(Arr, 1) 'theo dong'
Tmp = Year(Arr(iR, 2)) & "/" & Arr(iR, 3)
If Tmp = sNamMua Then
ArrKQ(iC, s) = ArrCT(iR, iC) 'gan cac tham so'
If ArrKQ(iC, 20) < ArrCT(iR, iC) Then ArrKQ(iC, 20) = ArrCT(iR, iC) 'Max
If ArrCT(iR, iC) = "" Then 'Min
ArrKQ(iC, 21) = ArrKQ(iC, 21)
ElseIf ArrKQ(iC, 21) = "" Or ArrKQ(iC, 21) > ArrCT(iR, iC) Then
ArrKQ(iC, 21) = ArrCT(iR, iC)
End If
ArrKQ(iC, 19) = ArrKQ(iC, 19) + ArrKQ(iC, s) 'tong so
If Len(ArrKQ(iC, s)) > 0 Then
solan = solan + 1
End If
Exit For 'thoat vong lap iR vi chi xuat hien 1 lan sNamMua = Tmp'
End If
Next iR
Next iMua
Next iNam
If solan = 0 Then
ArrKQ(iC, 19) = 0
Else
ArrKQ(iC, 19) = ArrKQ(iC, 19) / solan
End If
Next iC
'Tao lai Arr gan vao form, co the gan thang o tren
ReDim ArrForm(1 To 19, 1 To 13)
For iR = 1 To 19
For iC = 9 To 21
ArrForm(iR, iC - 8) = ArrKQ(iR, iC)
Next iC
Next iR
With Sheets("FormMau").Range("D6").Resize(19, 13)
.ClearContents
.Value = ArrForm
End With
bien:
Erase Arr, ArrCT, ArrKQ, ArrMua(), ArrForm()
Set wf = Nothing: Set myRng = Nothing
End Sub