Xem file đính kèm. Cần 20 ký tự.....ẹ
=IFERROR(SMALL(IF($A$1:$A$16=$D4,$B$1:$B$16),COLUMN(A1)),"")
Thế tui làm bằng VBA + thêm kiểu ông muốn được chứ ("người đẹp" chắc đi tìm zai rùi).
Sub HMTC()
Dim Arr(), vlArr(1 To 65000, 1 To 100), I, K, Tem, Dic, x
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
Arr = .Range(.[A1], .[B65000].End(3)).Value
For I = 1 To UBound(Arr)
Tem = Arr(I, 1)
If Not Dic.Exists(Tem) Then
K = K + 1
Dic.Add Tem, K
vlArr(K, 1) = Arr(I, 1)
vlArr(K, 2) = Arr(I, 2)
x = 2
Else
x = x + 1
vlArr(K, x) = Arr(I, 2)
End If
Next
.[D4].Resize(K, I) = vlArr
End With
Set Dic = Nothing
End SubVBA thì xài tạm code này nhé. Code mình viết hơi loằng ngoằng, bạn chịu khó đọc nha.
Sub ChuyenSoLieu()
Dim i As Long, k As Long, kR As Long, kRmax As Long
Dim Dic As Object
Dim sArr(), dArr()
sArr = Sheet1.Range("A1:B" & Sheet1.[B65536].End(xlUp).Row).Value
kR = UBound(sArr, 2)
kRmax = kR
ReDim dArr(1 To UBound(sArr), 1 To kRmax)
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(sArr)
If Not .Exists(sArr(i, 1)) Then
k = k + 1
.Add sArr(i, 1), Array(k, kR)
dArr(k, 1) = sArr(i, 1)
dArr(k, kR) = sArr(i, 2)
Else
ii = .Item(sArr(i, 1))(0)
jj = .Item(sArr(i, 1))(1)
If jj + kR - 1 > kRmax Then kRmax = jj + kR - 1
ReDim Preserve dArr(1 To UBound(sArr, 1), 1 To kRmax)
dArr(ii, jj + 1) = sArr(i, 2)
.Item(sArr(i, 1)) = Array(ii, jj + kR - 1)
End If
Next
End With
Sheet1.[D4:M100].ClearContents
Sheet1.Range("D4").Resize(k, kRmax) = dArr
End SubChứ viết sao thì mới được ta? Thế để sửa lại vậy
code của bạn "hên" cái là bảng nguồn đã được xếp Group theo cột A nên sẽ chạy đúng , mà nếu đã như vậy thì ta cũng không cần thiết sử dụng Dic làm gì , Nếu bạn có viết lại thì cũng nên viết theo #5 để chủ Topic có giải pháp tham khảo nhé . Cám ơn bạn . hi hiChứ viết sao thì mới được ta? Thế để sửa lại vậy
mình không biết làm bạn ơi . hic hic
À không. Tui viết là giành cho hpkhuong. Hôm qua có hỏi tôi vụ này mà viết theo DIC (chứ có viết cho chủ topic đâu). Bởi nãy làm công thức xong rồi, #2 post nhanh quá nên mới không post nữa ấy chứ. Bữa nay không có "kèo" nên nghịch tí. Còn vụ Sort sẵn cơ bản chỉ dùng mảng và vòng lặp là được rồi. Đề dễ thì mình làm khỏe. Đơn giản là vậy thôi mà.
Bạn hay lắm hpKhuong à , người ta chỉ viết code cho bạn thui chứ hổng chơi với tôi , thôi thì đành viết theo #5 với dữ liệu đã Group sẵn theo cột AHic hic "1 Sao đây sợ chưa" thật là khiêm tốn, Vậy đợi 2 bạn Giang bình Phương múa tiếp vậy...
Public Sub hello()
Dim arr, dArr, sRow() As Long, r As Long, k As Long, tp, ub As Long, hRG As Range
With Sheet1
arr = .Range(.[A1], .[A65000].End(xlUp)).Resize(, 2).Value
ub = UBound(arr)
ReDim dArr(1 To ub, 1 To ub)
For r = 1 To UBound(arr) Step 1
If arr(r, 1) <> tp Then
k = k + 1
ReDim Preserve sRow(1 To k)
sRow(k) = 1
dArr(1, k) = arr(r, 1)
tp = arr(r, 1)
End If
sRow(k) = sRow(k) + 1
dArr(sRow(k), k) = arr(r, 2)
Next
.Range("D4:Z1000").ClearContents
.Range("D4").Offset(, ub + 1).Resize(ub, k).Value = dArr
For r = 1 To k Step 1
Set hRG = .Range("D4").Offset(1, r + ub)
hRG.Resize(sRow(r)).Sort hRG, Header:=xlNo
Next
Set hRG = .Range("D4").Offset(, ub + 1).CurrentRegion
hRG.Copy
.Range("D4").PasteSpecial xlPasteValues, , , True
hRG.ClearContents
End With
End Sub
Sub BuDongLe()
Dim sArr(), ColC()
Dim MA As String
Dim krMax As Long, Col_M As Long, vTr As Long, i As Long
sArr = Sheet1.Range("A1:B" & Sheet1.[B65536].End(xlUp).Row).Value
ReDim dArr(1 To UBound(sArr), 1 To UBound(sArr))
For i = 1 To UBound(sArr, 1)
If InStr(1, MA, sArr(i, 1)) = 0 Then
MA = MA & (sArr(i, 1))
krMax = krMax + 1
ReDim Preserve ColC(1 To krMax)
dArr(krMax, 1) = sArr(i, 1)
dArr(krMax, 2) = sArr(i, 2)
ColC(krMax) = 2
Else
vTr = Int(InStr(1, MA, sArr(i, 1)) / 6) + 1 ' lay lai vi tri cua chuoi da xuat hien
dArr(vTr, ColC(vTr) + 1) = sArr(i, 2)
ColC(vTr) = ColC(vTr) + 1
If Col_M < ColC(vTr) Then Col_M = ColC(vTr)
End If
Next
With Sheet1
.[D4:Y1000].ClearContents
.[D4].Resize(krMax, Col_M) = dArr
End With
End SubMột thiếu nữ xinh đẹp và hấp dẫn như bạn doveandrose không chơi sao được,
Hehehee...... Tự sướng đi nhá, hỏng có rảnh. Ních xanh không liên quan...............................hahahaha.
