Nhờ các sư huynh tỉ muội, sữa giúp đoạn code copy 2 files của excel nó bị thiếu gì mà chạy báo lỗi.
xin cảm ơn trước.
HTML:
Public Sub COPY1()
Dim Rng1(), Rng2(), Arr(), Arr2(), Dic As Object, Dic2 As Object
Dim Ws1 As Worksheet, Ws2 As Worksheet, I As Long, J As Long, K As Long
Set Dic = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
Application.Workbooks.Open (ThisWorkbook.Path & "\CHITIET.XLSM")
Set Ws1 = Workbooks("CHITIET").Worksheets("CHITIET")
Set Ws2 = Workbooks("KETQUA").Worksheets("KETQUA")
Rng2 = Ws2.Range(Ws2.[E2], Ws2.[E2].End(xlToRight)).Resize(2).Value
Rng1 = Ws1.Range(Ws1.[E2], Ws1.[E2].End(xlToRight)).Resize(2).Value
ReDim Arr(1 To 2, 1 To UBound(Rng2, 2) + UBound(Rng1, 2))
For I = 1 To UBound(Rng2, 2)
K = K + 1
Dic.Add Rng2(1, I) & Rng2(2, I), K
Arr(1, K) = Rng2(1, K): Arr(2, K) = Rng2(2, K)
Next I
For J = 1 To UBound(Rng1, 2)
If Not Dic.exists(Rng1(1, J) & Rng1(2, J)) Then
K = K + 1
Dic.Add Rng1(1, J) & Rng1(2, J), K
Arr(1, K) = Rng1(1, J): Arr(2, K) = Rng1(2, J)
End If
Next J
Ws2.[E2].Resize(2, K) = Arr
'----------------------
Rng2 = Ws2.Range(Ws2.[A4], Ws2.[A65000].End(xlUp)).Resize(, K + 4).Value
ReDim Arr2(1 To UBound(Rng2, 1), 1 To UBound(Rng2, 2))
For I = 1 To UBound(Rng2, 1)
If Not Dic2.exists(Rng2(I, 1) & Rng2(I, 2) & Rng2(I, 4)) Then
Dic2.Add Rng2(I, 1) & Rng2(I, 2) & Rng2(I, 4), I
End If
For J = 1 To UBound(Rng2, 2)
Arr2(I, J) = Rng2(I, J)
Next J
Next I
'---------------
Rng1 = Ws1.Range(Ws1.[A4], Ws1.[A65000].End(xlUp)).Resize(, Ws1.[E2].End(xlToRight).Column).Value
For I = 1 To UBound(Rng1, 1)
For J = 5 To UBound(Rng1, 2)
If Rng1(I, J) > 0 Then
Arr2(Dic2.Item(Rng1(I, 1) & Rng1(I, 2) & Rng1(I, 4)), Dic.Item(Ws1.Cells(2, J) & Ws1.Cells(3, J)) + 4) = Rng1(I, J)
End If
Next J
Next I
Ws2.[A4].Resize(UBound(Rng2, 1), UBound(Rng2, 2)).Value = Arr2
Set Dic = Nothing
Set Dic2 = Nothing
Set Ws1 = Nothing
Set Ws2 = Nothing
End Subxin cảm ơn trước.
