Mở File nhấn nút "GỘP" xem kết quả đã đúng chưa? Nhớ Enable Macros trước khi mở File nhé!
Public Sub Chuot0106_Gop()
Dim i As Long, j As Long, kq(), data(), data1(), chuoi As String
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
data = Sheet1.Range("A2:B" & Sheet1.Range("B65500").End(xlUp).Row)
ReDim kq(1 To UBound(data), 1 To 1)
For i = 1 To UBound(data)
If Not Dic.Exists(data(i, 1)) Then
j = j + 1
Dic.Add data(i, 1), j
End If
Next i
Sheet1.Range("F2").Resize(j).Value = Application.Transpose(Dic.Keys)
data1 = Sheet1.Range("F2:F" & Sheet1.Range("F65500").End(xlUp).Row)
For i = 1 To UBound(data1)
chuoi = ""
For j = 1 To UBound(data)
If data(j, 1) = data1(i, 1) Then
chuoi = chuoi & data(j, 2) & ", "
End If
Next j
kq(i, 1) = Left(chuoi, Len(chuoi) - 2)
Next i
Sheet1.Range("G2").Resize(j, 1) = kq
End Sub
Mong anh góp ý! Vì em học theo kiểu chắp nhặt nên có thể code chưa được tối ưu.
Mình thì có thói quen riêng rồi. Dữ liệu không nhiều thì xử vầy cho gọn
Sub Chuot0106_Gop()
Dim i As Long, data()
With CreateObject("Scripting.Dictionary")
data = Range([A2], [B65536].End(3)).Value
For i = 1 To UBound(data)
If Not .Exists(data(i, 1)) Then
.Add data(i, 1), data(i, 2)
Else
.Item(data(i, 1)) = _
.Item(data(i, 1)) & "," & data(i, 2)
End If
Next i
[F2].Resize(.Count) = Application.Transpose(.Keys)
[G2].Resize(.Count) = Application.Transpose(.Items)
End With
End Sub
Function JoinText(ByVal Delimiter As String, ParamArray Arrays()) As String
Dim aTmp, Arr(), Item, tmp As String
Dim i As Long, n As Long
'On Error Resume Next
For i = LBound(Arrays) To UBound(Arrays)
aTmp = Arrays(i)
If Not IsArray(aTmp) Then aTmp = Array(aTmp)
For Each Item In aTmp
If TypeName(Item) <> "Error" Then
tmp = CStr(Item)
n = n + 1
ReDim Preserve Arr(1 To n)
Arr(n) = tmp
End If
Next
Next
If n Then JoinText = Join(Arr, Delimiter)
End Function
Function UniqueList(ParamArray sArray())
Dim Item, tmpArr, SubArr, tmp
'On Error Resume Next
With CreateObject("Scripting.Dictionary")
For Each SubArr In sArray
tmpArr = SubArr
If Not IsArray(tmpArr) Then tmpArr = Array(tmpArr)
For Each Item In tmpArr
tmp = CStr(Item)
If Len(tmp) Then
If Not .Exists(tmp) Then .Add tmp, ""
End If
Next
Next
If .Count Then UniqueList = .Keys
End With
End Function=IF(COUNTA(UniqueList($A$2:$A$100))<ROWS($1:1),"",INDEX(UniqueList($A$2:$A$100),,ROWS($1:1)))=IF(F2="","",JoinText(", ",IF($A$2:$A$100=F2,$B$2:$B$100,NA())))Không rõ là cám ơn ai? Hy vọng là có mình trong đó.
Mình cảm ơn anh ndu96081631, anh quanghai1969
