Option Explicit
Sub main()
Dim i As Long, i1 As Long, rend As Long
Dim c As Integer, cend As Integer
Dim shn As String, lk As String, wbdl As String, wbkh As String, skey As String
Dim arr
Dim myDic As Object
'File DL
Const r1 As Long = 6 'Dong tieu de: 1,2,3,4,...
Const c1 As Integer = 1 'Cot A: BB,C,DD,E1,C1
'File KH
Const cQ As Integer = 17 'Cot Q
Const r2 As Long = 13 'Dong tieu de: 1,2,3,...
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set myDic = CreateObject("Scripting.Dictionary")
'Lam viec voi file DL
lk = ThisWorkbook.Sheets("tuhocvba").Cells(2, 2)
Workbooks.Open lk
wbdl = ActiveWorkbook.Name
For i = 1 To Workbooks(wbdl).Sheets.Count Step 1
Workbooks(wbdl).Sheets(i).Activate
shn = Workbooks(wbdl).Sheets(i).Name
'Don cuoi cung tren cot A- File DL
rend = Workbooks(wbdl).Sheets(i).Cells(Rows.Count, c1).End(xlUp).Row
cend = Workbooks(wbdl).Sheets(i).Cells(r1, Columns.Count).End(xlToLeft).Column
If ((rend > r1) And (cend > c1)) Then
arr = Workbooks(wbdl).Sheets(i).Range(Cells(r1, c1), Cells(rend, cend)).Value
'Chay tu dong dau + 1 toi dong cuoi, chay tu cot dau + 1 toi cot cuoi
For i1 = LBound(arr, 1) + 1 To UBound(arr, 1) Step 1
If CStr(arr(i1, 1)) <> "" Then 'BB, C,DD,E1
For c = LBound(arr, 2) + 1 To UBound(arr, 2) Step 1
If CStr(arr(i1, c)) <> "" Then
'Nap du lieu vao Dic: skey = tensheet_tuhocvba_BB_congdongvbavn_1
skey = shn & "_tuhocvba_" & CStr(arr(i1, 1)) & "_congdongvbavn_" & CStr(arr(1, c))
If Not myDic.Exists(skey) Then myDic.Add skey, arr(i1, c)
End If
Next c
End If
Next i1
End If
Next i
Workbooks(wbdl).Close
'Lam viec voi file KH
lk = ThisWorkbook.Sheets("tuhocvba").Cells(3, 2)
Workbooks.Open lk
wbkh = ActiveWorkbook.Name
'Ghi du lieu vao file KH
For i = 1 To Workbooks(wbkh).Sheets.Count Step 1
Workbooks(wbkh).Sheets(i).Activate
shn = Workbooks(wbkh).Sheets(i).Name
'Don cuoi cung tren cot Q- File KH
rend = Workbooks(wbkh).Sheets(i).Cells(Rows.Count, cQ).End(xlUp).Row
cend = Workbooks(wbkh).Sheets(i).Cells(r2, Columns.Count).End(xlToLeft).Column
If ((rend > r2) And (cend > cQ)) Then
With Workbooks(wbkh).Sheets(i)
For i1 = r2 + 1 To rend Step 1
If .Cells(i1, cQ) <> "" Then
For c = cQ + 1 To cend Step 1
skey = shn & "_tuhocvba_" & .Cells(i1, cQ) & "_congdongvbavn_" & .Cells(r2, c)
If myDic.Exists(skey) Then .Cells(i1, c) = myDic.Item(skey)
Next c
End If
Next i1
End With
End If
Next i
MsgBox "Hoan thanh"
Workbooks(wbkh).Save
Workbooks(wbkh).Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function selectfile(ByVal sTitle As String) As String
Dim strFilePath As String
selectfile = Application.GetOpenFilename(Filefilter:="ExcelFile,*.xls?", Title:=sTitle)
End Function
