Bạn thử xem đã đúng ý chưa. Dữ liệu bạn tổng hợp ỏ file đính kèm sai nhé. Bạn cung cấp thêm dữ liệu và nhấn nút để xem kết quả.
Option Base 1
Sub TACH()
Dim dic As New Scripting.Dictionary
Dim s As String
Dim TU As String
Dim ArrN()
Dim Arr() As Variant
Dim KQ(), Nrr()
Dim n As Integer, m As Integer
Dim i As Integer
Dim k As Integer
Dim d As Long
Dim j&
Dim H&, Z&, c&, t&, f&
With Sheet1
d = .Range("A" & .Rows.Count).End(xlUp).Row
ArrN = .Range("A1:C" & d).Value
ReDim Arr(1 To d + 1, 1 To 3)
For i = 2 To d
s = WorksheetFunction.Substitute(.Cells(i, 1), ",", "")
n = Len(s)
H = H + n
Z = Z + 1
Arr(Z, 1) = s
For c = 2 To 3
Arr(Z, c) = ArrN(i, c)
Next c
Next i
ReDim KQ(1 To H, 1 To d)
On Error Resume Next
.Range("H2:IVA2").ClearContents
For k = 1 To UBound(Arr)
If Not dic.Exists(Arr(k, 3)) Then
.Cells(2, 100).End(xlToLeft).Offset(0, 1) = Arr(k, 3)
End If
Next k
For k = 1 To UBound(Arr)
f = Application.WorksheetFunction.Match(.Cells(k + 1, 3), .Range("G2:R2"))
n = Len(Arr(k, 1))
For j = 1 To n
DK = Mid(Trim(Arr(k, 1)), j, 1)
If Not dic.Exists(DK) Then
t = t + 1
dic.Add DK, t
KQ(t, 1) = DK
KQ(t, f) = Arr(k, 2) / n
Else
r = dic.Item(DK)
KQ(r, f) = KQ(r, f) + Arr(k, 2) / n
End If
Next j
Next k
.[G10].Resize(H, d) = KQ
End With
MsgBox " HÃY GUI LOI CAM ON ÐÊN BQT DIÊN ÐÀN VÀ CÁ NHAN CÁC ANH NDU, PTM, VETMINI,HUUTHANG,HIEUCD,SA_DQ....NHÉ!"
End Sub
