Bài này bạn dùng consoliadte thử xem
Mình muốn code vì tên sheet(01) & sheet(02) mình đổi tên khác vẫn lấy kết quả được.
Private Sub CommandButton1_Click()
Dim Arr(), Darr(), I As Long
Dim Dic As Object, J As Long, Tem As String
With Sheet1
Arr = .Range("B5", .[B65536].End(xlUp)).Resize(, 4).Value
End With
Set Dic = CreateObject("scripting.dictionary")
For I = 1 To UBound(Arr)
Tem = Arr(I, 1) & Arr(I, 2) & Arr(I, 3)
Dic(Tem) = Dic.Item(Tem) + Arr(I, 4)
Next
'----------------------------------------------------------------------
With Sheet3
Darr = .Range("B5", .[B65536].End(xlUp)).Resize(, 4).Value
For I = 1 To UBound(Darr)
Tem = Darr(I, 1) & Darr(I, 2) & Darr(I, 3)
Darr(I, 1) = Dic.Item(Tem)
Next
.[G5].Resize(I - 1) = Darr
End With
End Sub
Bạn chạy thử Sub này:
Public Sub GPE()
Dim Dic As Object, sArr(), dArr(1 To 100, 1 To 1), Ws As Worksheet
Dim I As Long, K As Long, R As Long, Rws As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
For Each Ws In ThisWorkbook.Worksheets
If Ws.Name <> "TONG" Then
If Ws.Range("B50000").End(xlUp).Row > 4 Then
sArr = Ws.Range("B5", Ws.Range("B50000").End(xlUp)).Resize(, 4).Value
Rws = UBound(sArr)
For I = 1 To Rws
Tem = sArr(I, 1) & "#" & sArr(I, 2) & "$" & sArr(I, 3)
If Not Dic.Exists(Tem) Then
K = K + 1
Dic.Item(Tem) = K
End If
R = Dic.Item(Tem)
dArr(R, 1) = dArr(R, 1) + sArr(I, 4)
Next I
End If
End If
Next Ws
With Sheets("TONG")
Rws = .Range("B50000").End(xlUp).Row
For I = 5 To Rws
Tem = .Range("B" & I) & "#" & .Range("C" & I) & "$" & .Range("D" & I)
If Dic.Exists(Tem) Then
.Range("F" & I) = dArr(Dic.Item(Tem), 1)
End If
Next I
End With
Set Dic = Nothing
End SubHay quá cám ơn Anh rất nhiều.
