Sub CopyData()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
t = Timer
Dim MyDic As Object: Set MyDic = CreateObject("Scripting.Dictionary")
Dim MyDic2 As Object: Set MyDic2 = CreateObject("Scripting.Dictionary")
Dim ActiveWS As Worksheet: Set ActiveWS = ThisWorkbook.Sheets("Sheet2")
Dim ArrReport(), ArrDulieu(), ArrKQ()
Dim i As Long, k As Long, l As Long, sCol As Long, jR As Long, jCol As Long, sM As Long, m As Long
Dim sYear As String, sMonth As String
Call Get_Array(ArrDulieu, sAdress, ThisWorkbook.Name, "Sheet3", 2, "Content", 2)
Call Create_Dic(MyDic, ArrDulieu, 2, 1, "", "", "", "", "", "")
ReDim ArrKQ(1 To 4, 1 To 1)
With ActiveWS
For i = 1 To 100
If .Cells(1, i) <> "" Then
If .Cells(1, i) = "Year:" Then
ArrReport = GetArr(ThisWorkbook.Name, ActiveWS.Name, 1, i, 8, 2)
Call Create_Dic(MyDic2, ArrReport, 1, 1, "", "", "", "", "", "")
sYear = UCase(ArrReport(1, 2)): sMonth = UCase(ArrReport(2, 2))
For l = 2 To UBound(ArrDulieu, 1)
If UCase(ArrDulieu(l, 1)) Like sYear Then
For sM = 1 To 48
If UCase(ArrDulieu(l + sM, 1)) Like sMonth Then
jR = l + sM + 3 'Row Resize
For sCol = 1 To 8
If MyDic.Exists(ArrReport(sCol, 2)) Then
jCol = MyDic.Item(ArrReport(sCol, 2)) + 1 'Column Resize
End If
Next
'Tim Unit
m = 0
For o = 1 To 3
If MyDic2.Exists((ArrDulieu(l + sM + o, 1))) Then
m = m + 1
ArrKQ(m, 1) = ArrReport(MyDic2.Item((ArrDulieu(l + sM + o, 1))), 2) 'ket qua tra ve
End If
Next
End If
Next
End If
Next
ThisWorkbook.Sheets("Sheet3").Cells(jR, jCol).Resize(4, 1) = ArrKQ
End If
End If
Next
End With
MsgBox "Report Data :" & Format(Timer - t, "0.00") & "s", vbInformation, "Thông Bao "
Erase ArrDulieu: Erase ArrReport: Erase ArrKQ
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Function GetArr(WorkbookName As String, Sheetname As String, sR As Long, i As Long, iR As Long, iCol As Long)
Dim Arrdata As Variant
Dim ActiveWB, ActiveWS
Set ActiveWB = Application.Workbooks(WorkbookName)
Set ActiveWS = ActiveWB.Sheets(Sheetname)
With ActiveWS
If iR > 0 And iCol > 0 Then
Arrdata = .Cells(sR, i).Resize(iR, iCol).Value
End If
End With
GetArr = Arrdata
End Function
Private Sub Get_Array(ArrRawdata As Variant, sRng, Bookname As String, Sheetname As String, sCol As Long, sValue As String, ColeR As Long)
Dim i&, j&, eR&, eC&
Dim TargetSheet As Worksheet
Dim TargetBooks As Workbook
Set TargetBooks = Application.Workbooks(Bookname)
Set TargetSheet = TargetBooks.Sheets(Sheetname)
'-> clear filter
If TargetSheet.AutoFilterMode Then TargetSheet.AutoFilter.ShowAllData
For i = 1 To 100000
If TargetSheet.Cells(i, sCol).Value = sValue Then
sRng = TargetSheet.Cells(i, sCol).Address
Exit For
End If
Next
eR = TargetSheet.Cells(1048576, ColeR).End(3).Row
eC = TargetSheet.Range("XDF" & TargetSheet.Range(sRng).Row).End(1).Column
ArrRawdata = TargetSheet.Range(sRng, Cells(eR, eC).Address).Value
End Sub
Private Sub Create_Dic(ByRef dic, ByRef Arr1, ub1, RC1, ByRef arr2, ub2, RC2, ByRef Arr3, ub3, RC3)
Dim i&, j&, k&, iKey
Set dic = CreateObject("Scripting.Dictionary")
'--> Add Arr1 to dic
If ub1 <> "" Then
For i = 1 To UBound(Arr1, ub1)
iKey = Arr1(IIf(ub1 = 1, i, RC1), IIf(ub1 = 1, RC1, i))
If iKey <> "" Then
If Not dic.Exists(iKey) Then
dic.Add iKey, i
End If
End If
Next
End If
'--> Add Arr2 to dic
If ub2 <> "" Then
For j = 1 To UBound(arr2, ub2)
iKey = arr2(IIf(ub2 = 1, j, RC2), IIf(ub2 = 1, RC2, j))
If iKey <> "" Then
If Not dic.Exists(iKey) Then
dic.Add iKey, j
End If
End If
Next
End If
'--> Add Arr3 to dic
If ub3 <> "" Then
For k = 1 To UBound(Arr3, ub3)
iKey = Arr3(IIf(ub3 = 1, k, RC3), IIf(ub3 = 1, RC3, k))
If iKey <> "" Then
If Not dic.Exists(iKey) Then
dic.Add iKey, k
End If
End If
Next
End If
End Sub
)
