Option Explicit
Option Compare Text
Sub tohopDiem()
Dim TohopBGD
Dim Bangdiem
Dim ThongkeCanhan
Dim Tam, Ten, Diem, Stt
Dim diemMax, tenMax
Dim TohopMon
Dim kq
Dim rws, cls
Dim i, j, k, x, z, t
With Sheet1
TohopBGD = .Range("A3:B18")
Bangdiem = .Range("P2:Z20")
ThongkeCanhan = .Range("AA2:AZ2")
End With
rws = UBound(Bangdiem)
cls = UBound(Bangdiem, 2)
ReDim kq(1 To rws, 1 To UBound(ThongkeCanhan, 2))
With CreateObject("Scripting.Dictionary")
For j = 3 To UBound(ThongkeCanhan, 2)
.Item(Application.Trim(ThongkeCanhan(1, j))) = j
Next j
For i = 1 To UBound(TohopBGD)
.Item(Application.Trim(TohopBGD(i, 2))) = .Item(Application.Trim(TohopBGD(i, 1)))
Next i
For i = 2 To rws
ReDim Tam(1 To 2, 1 To cls)
k = 0
For j = 1 To cls
If Bangdiem(i, j) <> "" Then
k = k + 1
Tam(1, k) = Bangdiem(1, j)
Tam(2, k) = Bangdiem(i, j)
End If
Next j
ReDim Preserve Tam(1 To 2, 1 To k)
lapTohop k, 3, TohopMon
diemMax = 0
For x = 0 To UBound(TohopMon)
Ten = ""
Diem = 0
For z = 0 To UBound(TohopMon(x))
Ten = Ten & " " & Tam(1, TohopMon(x)(z) + 1)
Diem = Diem + Tam(2, TohopMon(x)(z) + 1)
Next z
Ten = Trim(Ten)
If .exists(Ten) Then
Stt = .Item(Ten)
kq(i - 1, Stt) = Diem
If diemMax < Diem Then
diemMax = Diem
tenMax = Ten
End If
End If
Next x
kq(i - 1, 1) = ThongkeCanhan(1, .Item(tenMax))
kq(i - 1, 2) = diemMax
Next i
End With
Sheet2.Range("AA3:AZ18").ClearContents
Sheet2.Range("AA3").Resize(UBound(kq), UBound(kq, 2)) = kq
End Sub