Giúp code lọc tên hàng sang từng nhóm hàng riêng biệt (1 người xem)

[congnguyen88]

Mình có 1 bảng tính excel gồm có 2 cột Tên hàng và Nhóm hàng, mình muốn lọc các Nhóm hàng sang cột phía bên phải, bao nhiêu nhóm hàng thì tương ứng bấy nhiêu cột, và tên hàng nào thì phải nằm theo cột của nhóm hàng đó.
Mính có gửi File anh em mở ra xem mình có vị dụ nên xem là hiểu ak. Mong các anh em nhiệt tình giúp đỡ. Xin cảm ơn nhiều nhiều

 

[ChanhTQ@]

Bạn tạm thử với cái này trong khi chờ các cái khác hay hơn

{CTRL}+{SHIFT}+R

 

[congnguyen88]

Bạn tạm thử với cái này trong khi chờ các cái khác hay hơn

{CTRL}+{SHIFT}+R

cảm ơn bạn. hình như ban sort roi bạn copy lai hay sao, thế thì hok được bạn, mình muốn dùng code ak. chứ bảng dữ liệu của mình 5000 dòng thì copy chắc tới sáng cũng chưa xong đó

 

[sealand]

Bạn thử với Code sau xem sao:

Sub TransCl()
Dim Dic As Object, Retval(), Tm
Dim eR(), eRmax, Id, i, j
Set Dic = CreateObject("Scripting.Dictionary")
Tm = Sheet1.[A2:B2].Resize(Sheet1.[A65536].End(3).Row - 1)
For i = 1 To UBound(Tm, 1)
If Not Dic.exists(Tm(i, 2)) Then
j = j + 1
Dic.Add Tm(i, 2), j
ReDim Preserve eR(1 To j)
eR(j) = 1
ReDim Preserve Retval(1 To UBound(Tm, 1), 1 To j)
Retval(1, j) = Tm(i, 2)
End If
Id = Dic.Item(Tm(i, 2))
eR(Id) = eR(Id) + 1
If eRmax < eR(Id) Then eRmax = eR(Id)
Retval(eR(Id), Id) = Tm(i, 1)
Next
Sheet1.[H2:Z65536].ClearContents
Sheet1.[H2].Resize(eRmax, UBound(Retval, 2)) = Retval
Set Dic = Nothing
End Sub

 

[phihndhsp]

cảm ơn bạn. hình như ban sort roi bạn copy lai hay sao, thế thì hok được bạn, mình muốn dùng code ak. chứ bảng dữ liệu của mình 5000 dòng thì copy chắc tới sáng cũng chưa xong đó

Máy tôi bị sao sao nên nó không cho lưu
bạn copy cái này vào module rồi cho nó chạy xem sao nha

Function UniqueList(ParamArray sArray())
  Dim Item, tmpArr, SubArr
  On Error Resume Next
  With CreateObject("Scripting.Dictionary")
    For Each SubArr In sArray
      tmpArr = SubArr
      If TypeName(tmpArr) <> "Variant()" Then
        If tmpArr <> "" Then .Add tmpArr, ""
      Else
        For Each Item In tmpArr
          If Item <> "" Then
            If Not .Exists(Item) Then .Add Item, ""
          End If
        Next
      End If
    Next
    If .Count Then UniqueList = .Keys
  End With
End Function

Sub LOC()
    Dim Arr, tmpArr, I As Long
    Dim SODONG  As Long
    SODONG = Sheet1.Range("B65000").End(xlUp).Row
     tmpArr = UniqueList(Sheet1.Range("B11:B" & SODONG))
       If IsArray(tmpArr) Then
          ReDim Arr(1 To 1, 1 To UBound(tmpArr) + 1)
          For I = 0 To UBound(tmpArr)
              Arr(1, I + 1) = tmpArr(I)
          Next
      End If
      Sheet1.Range("D3:Z10000").ClearContents
      Sheet1.Range("D3").Resize(1, I).Value = Arr
      
     'DUA DU LIEU QUA BAN 2
    Dim ARR_Dich()
    Dim ARR_Nguon()
    Dim TAM As String
    ReDim ARR_Nguon(1 To SODONG, 1 To 2)
    ARR_Nguon = Sheet1.Range("A3:B" & SODONG).Value
    
    Dim DEM As Long
    ReDim ARR_Dich(1 To UBound(ARR_Nguon), 1 To UBound(Arr, 2))
    For J = 1 To UBound(Arr, 2)
        DEM = 0
            For I = 1 To SODONG - 2
          
                If ARR_Nguon(I, 2) = Arr(1, J) Then
                    DEM = DEM + 1
                    ARR_Dich(DEM, J) = ARR_Nguon(I, 1)
                End If
            Next I
    
    Next J
       Sheet1.Range("D4:Z1000").Borders.LineStyle = 0
       Sheet1.Range("D4").Resize(UBound(ARR_Dich, 1), UBound(Arr, 2)).Value = ARR_Dich
       Sheet1.Range("D4").Resize(Sheet1.Range("D65000").End(xlUp).Row - 2, UBound(Arr, 2)).Borders.LineStyle = 1
End Sub

 

[SA_DQ]

Mình cũng thử tập tành với Disc xem sao,sau khi tham khảo bài của Sealand:

Option Explicit
Sub TransC2()
 Dim Dic As Object, Tmp()
 Dim J As Long, Col As Integer, Dg As Long
 
 Set Dic = CreateObject("Scripting.Dictionary")
 Tmp = Sheet1.[A2].Resize(Sheet1.[A3].CurrentRegion.Rows.Count, 2).Value
 ReDim Arr(1 To Sheet1.[A3].CurrentRegion.Rows.Count, 1 To 17)
 For J = 1 To UBound(Tmp, 1)
    If Not Dic.exists(Tmp(J, 2)) Then
        Col = 1 + Col
        Dic.Add Tmp(J, 2), Col
        Arr(1, Col) = Tmp(J, 2):                Arr(2, Col) = Tmp(J, 1)
        Dg = 2
    Else
        Dg = Dg + 1:                            Arr(Dg, Col) = Tmp(J, 1)
    End If
 Next J
 Sheet1.[H12].Resize(999, 17).Clear
 Sheet1.[H12].Resize(999, 17).Value = Arr()
End Sub

 

[VetMini]

cảm ơn bạn. hình như ban sort roi bạn copy lai hay sao, thế thì hok được bạn, mình muốn dùng code ak. chứ bảng dữ liệu của mình 5000 dòng thì copy chắc tới sáng cũng chưa xong đó

Trời. Copy 5000 dòng mà cũng sợ đến sáng!

Kể từ rày mình nên mách bảo các bạn đi xin việc làm, nếu người phỏng vấn hỏi: "tình độ sử dụng Excel của bạn ra sao?"
Trả lời:
"Không biết nhiều, nhưng tôi biết cách gởi file lên GPE"

 

[ChanhTQ@]

Bạn căn cứ vào đâu mà nói như vậy?

Hình như ban sort roi bạn copy lai hay sao, thế thì hok được bạn, mình muốn dùng code ak. chứ bảng dữ liệu của mình 5000 dòng thì copy chắc tới sáng cũng chưa xong đó

Mình đã thử với cả 3 macro trên CSDL gồm 15 nhóm hàng với 3.355 dòng thì nhận được kết quả thời gian theo đơn vị giây như sau

[TABLE="class: grid, width: 300, align: center"]
[TR]
[TD]Macro [/TD]
[TD]Giây[/TD]
[/TR]
[TR]
[TD]Bài 2[/TD]
[TD].953[/TD]
[/TR]
[TR]
[TD]Bài 4[/TD]
[TD].109[/TD]
[/TR]
[TR]
[TD]Bài 6[/TD]
[TD].065[/TD]
[/TR]
[/TABLE]

 

[congnguyen88]

Bạn thử với Code sau xem sao:

Sub TransCl()
Dim Dic As Object, Retval(), Tm
Dim eR(), eRmax, Id, i, j
Set Dic = CreateObject("Scripting.Dictionary")
Tm = Sheet1.[A2:B2].Resize(Sheet1.[A65536].End(3).Row - 1)
For i = 1 To UBound(Tm, 1)
If Not Dic.exists(Tm(i, 2)) Then
j = j + 1
Dic.Add Tm(i, 2), j
ReDim Preserve eR(1 To j)
eR(j) = 1
ReDim Preserve Retval(1 To UBound(Tm, 1), 1 To j)
Retval(1, j) = Tm(i, 2)
End If
Id = Dic.Item(Tm(i, 2))
eR(Id) = eR(Id) + 1
If eRmax < eR(Id) Then eRmax = eR(Id)
Retval(eR(Id), Id) = Tm(i, 1)
Next
Sheet1.[H2:Z65536].ClearContents
Sheet1.[H2].Resize(eRmax, UBound(Retval, 2)) = Retval
Set Dic = Nothing
End Sub

cảm ơn bạn. code của bạn quá tuyệt vời. quá đúng theo ý mình, chuẩn không cần chỉnh