Option Explicit
Sub VaoDiemCacLop_HUONG_HCKT()
Dim i&, j&, t&, k&, Lr&, eRow&, z&, R&, eR&, vitri&
Dim Arr(), KQ(), Diem(), DMon(), S
Dim Dic As Object, DicID As Object, Keys, Temp, ID, Ma
Dim wbDiem As Workbook, wbLop As Workbook, ShD As Worksheet, Sh As Worksheet
Dim fnameList As Variant
Dim fnameCurFile As Variant
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set ShD = Sheet1
Set Dic = CreateObject("Scripting.Dictionary")
Set DicID = CreateObject("Scripting.Dictionary")
eRow = ShD.Cells(Rows.Count, 2).End(xlUp).Row
Arr = ShD.Range("A5:N" & eRow).Value
R = UBound(Arr)
ReDim Diem(1 To R, 1 To 11)
For i = 1 To UBound(Arr)
Keys = Arr(i, 5): If Not Dic.Exists(Keys) Then t = t + 1: Dic.Add (Keys), t
ID = Trim(Arr(i, 2)) & "|" & Trim(Arr(i, 5))
If Not DicID.Exists(ID) Then
k = k + 1: DicID.Add (ID), k
Diem(k, 1) = ID
For j = 2 To 10
Diem(k, j) = Arr(i, j + 4)
Next j
End If
Next i
fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", _
Title:="Choose Excel files to merge", MultiSelect:=True)
'Set wbDiem = ActiveWorkbook
For Each Keys In Dic.Keys
For Each fnameCurFile In fnameList
vitri = InStr(1, fnameCurFile, Keys, vbTextCompare)
If vitri <> 0 Then
Temp = UCase(Mid(fnameCurFile, vitri, 3))
If Dic.Exists(Temp) Then
Set wbLop = Workbooks.Open(Filename:=fnameCurFile)
' On Error Resume Next
S = Array(0, 1, 2, 6, 7, 8, 9, 3, 4, 10)
For z = 1 To UBound(S)
Set Sh = Sheets(S(z))
Lr = Sh.Cells(Rows.Count, 2).End(xlUp).Row
DMon = Sh.Range("B8:B" & Lr).Value: eR = UBound(DMon)
ReDim KQ(1 To eR, 1 To 1)
For i = 1 To eR
Ma = Trim(DMon(i, 1)) & "|" & Temp
If DicID.Exists(Ma) Then
KQ(i, 1) = Diem(DicID.Item(Ma), z + 1)
End If
Next i
Sh.Range("J8").Resize(i, 1) = KQ
Erase KQ
Next z
End If
'wbLop.Close SaveChanges:=True
End If
Next fnameCurFile
Next Keys
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Set Dic = Nothing
Set DicID = Nothing
MsgBox " Đa vao điêm các môn cho các lop thành công", vbInformation, "THÔNG BÁO"
End Sub
