Option Explicit
Sub TONGHOPC2()
Dim Lr&, i&, j&, t&, K&, R&, C&, LrD&, Rd&, Cc&, Col&, cot&, N&, TONG
Dim Ws As Worksheet, Sh As Worksheet
Dim Arr(), ArrD(), KQCuoi()
Dim Key, Temp, eTmp, Tmp, Dic As Object, DicN As Object
Dim fnameList As Variant ' Tap hop cac file can lay du lieu
Dim fnameCurFile As Variant ' File duoc chon mo trong tap hop fnameList
Dim wbkCurBook As Workbook ' workbook duoc mo
Dim wbkSrcBook As Workbook
Dim wksCurSheet As Worksheet
'1: Lua chon cac file can ghep va tien hanh mo file = boi den va nhan nut open
fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm;*.xlsb),*.xls;*.xlsx;*.xlsm;*.xlsb", Title:="Choose Excel files to merge", MultiSelect:=True)
If (vbBoolean <> VarType(fnameList)) Then
If (UBound(fnameList) > 0) Then
'=======KHOA MAN HINH=================
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'2. Mo file trong tap hop file can lay du lieu
Set Dic = CreateObject("Scripting.Dictionary")
Set DicN = CreateObject("Scripting.Dictionary")
Set wbkCurBook = ActiveWorkbook ' Gán bien cho Workbook dươc mơ
For Each fnameCurFile In fnameList ' quet tung file trong tap hop
Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile) 'mo file
For Each Ws In wbkSrcBook.Sheets
Lr = Ws.Cells(Rows.Count, 1).End(xlUp).Row
Arr = Ws.Range("A2:F" & Lr).Value
R = UBound(Arr, 1): C = UBound(Arr, 2)
' ReDim KQ(1 To R, 1 To 6)
For Col = 1 To C
If IsDate(Arr(1, Col)) Then
Tmp = CDate(Arr(1, Col))
If Not DicN.Exists(Tmp) Then K = K + 1: DicN.Add (Tmp), K
End If
Next Col
For i = 1 To R
Temp = Trim(Arr(i, 1))
If Not Dic.Exists(Temp) Then
t = t + 1
Dic.Add (Temp), t
End If
Next i
Next Ws
wbkSrcBook.Close
Next fnameCurFile
Set Sh = Sheets("Data")
LrD = Sh.Cells(Rows.Count, 1).End(xlUp).Row
cot = Sh.Cells(2, Columns.Count).End(xlToLeft).Column
ArrD = Sh.Range(Cells(2, 1), Cells(Lr, cot)).Value
Rd = UBound(ArrD, 1): Cc = UBound(ArrD, 2)
ReDim KQua(1 To Rd, 1 To Cc)
For i = 2 To Rd
Key = Trim(ArrD(i, 1)): TONG = 0
If Dic.Exists(Key) Then
For j = 1 To Cc
If IsDate(ArrD(1, j)) Then
N = N + 1
eTmp = CDate(ArrD(1, j))
If DicN.Exists(eTmp) Then
KQua(i - 1, j - 1) = Arr(Dic.Item(Key), DicN.Item(eTmp) + 1)
TONG = TONG + Arr(Dic.Item(Key), DicN.Item(eTmp) + 1)
End If
End If
Next j
End If
KQua(i - 1, Cc - 1) = TONG / N '(Cc - 2)
Next i
Sh.Range("B3").Resize(Rd, Cc) = KQua
End If
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "OK", vbInformation, "THÔNG BÁO"
End Sub
[\code]
