Tự động liệt kê và sắp xếp dữ liệu

danghoan83 · 31/7/18

Các bạn giúp mình Liệt kê và sắp xếp dữ liệu với nha (Bằng hàm của Excel hoặc VBA cũng được ạ). Mình có gửi kèm file mẫu phía dưới. Cảm ơn rất nhiều.

dazkangel · 31/7/18

danghoan83 đã viết:
Các bạn giúp mình Liệt kê và sắp xếp dữ liệu với nha (Bằng hàm của Excel hoặc VBA cũng được ạ). Mình có gửi kèm file mẫu phía dưới. Cảm ơn rất nhiều.

Làm thử 1 tí, nhớ vào File/Excel Option/Formulas chọn Enable iterative calculation:

Phan Thế Hiệp · 31/7/18

dazkangel đã viết:
Làm thử 1 tí, nhớ vào File/Excel Option/Formulas chọn Enable iterative calculation:

"A,B,C,D" nữa em! không có sẵn, và cũng được sắp xếp theo alphabet, vậy mới vui!
Chúc em ngày vui.

truongvu317 · 31/7/18

Đưa file thật, dữ liệu thật lên, dùng vba cũng mướt mồ hôi luôn.

vanaccex · 31/7/18

Chắc cần phải tách ra dữ liệu dạng chuẩn rồ mới ghép được

truongvu317 · 31/7/18

vanaccex đã viết:
Chắc cần phải tách ra dữ liệu dạng chuẩn rồ mới ghép được

Gái có ý kiến gì hay thế, dạng chuẩn là sao thế?

excel_lv1.5 · 31/7/18

danghoan83 đã viết:
Các bạn giúp mình Liệt kê và sắp xếp dữ liệu với nha (Bằng hàm của Excel hoặc VBA cũng được ạ). Mình có gửi kèm file mẫu phía dưới. Cảm ơn rất nhiều.

Bài này loại trùng 2 lần thì nên dùng VBA, bạn thử code này:

PHP:

Sub a()
Dim rng As Range, dic As Object, dic2 As Object, cell As Range
Set rng = Range("B2:C" & [b10000].End(xlUp).Row)
Set dic = CreateObject("Scripting.dictionary")
Set dic2 = CreateObject("Scripting.dictionary")
For Each cell In rng
    If Not dic.exists(cell) Then dic.Add cell, ""
Next
For Each key In dic.keys()
    If Not dic2.exists(Split(key, ChrW(10))(1)) Then
        dic2.Add Split(key, ChrW(10))(1), Split(key, ChrW(10))(0)
    Else
        dic2.Item(Split(key, ChrW(10))(1)) = dic2.Item(Split(key, ChrW(10))(1)) & "," & Split(key, ChrW(10))(0)
    End If
Next key
[f2].Resize(dic2.Count, 1) = WorksheetFunction.Transpose(dic2.keys())
[g2].Resize(dic2.Count, 1) = WorksheetFunction.Transpose(dic2.items())
End Sub

danghoan83 · 31/7/18

dazkangel đã viết:
Làm thử 1 tí, nhớ vào File/Excel Option/Formulas chọn Enable iterative calculation:

Cảm ơn bạn nhiều. Rất oke.

Bài đã được tự động gộp: 31/7/18

excel_lv1.5 đã viết:

Bài này loại trùng 2 lần thì nên dùng VBA, bạn thử code này:

PHP:

Sub a()
Dim rng As Range, dic As Object, dic2 As Object, cell As Range
Set rng = Range("B2:C" & [b10000].End(xlUp).Row)
Set dic = CreateObject("Scripting.dictionary")
Set dic2 = CreateObject("Scripting.dictionary")
For Each cell In rng
    If Not dic.exists(cell) Then dic.Add cell, ""
Next
For Each key In dic.keys()
    If Not dic2.exists(Split(key, ChrW(10))(1)) Then
        dic2.Add Split(key, ChrW(10))(1), Split(key, ChrW(10))(0)
    Else
        dic2.Item(Split(key, ChrW(10))(1)) = dic2.Item(Split(key, ChrW(10))(1)) & "," & Split(key, ChrW(10))(0)
    End If
Next key
[f2].Resize(dic2.Count, 1) = WorksheetFunction.Transpose(dic2.keys())
[g2].Resize(dic2.Count, 1) = WorksheetFunction.Transpose(dic2.items())
End Sub

Cảm ơn bạn. Rất tuyệt.

Bạn sắp dữ liệu tăng dần (trong mỗi cell cột G) dùm mình luôn được không.

befaint · 31/7/18

Nhìn thấy 2 dic kìa. Ai rảnh thử cách khác xem...
Chưa xem dữ liệu nhưng transpose thì cần xem kỹ về kiểu dữ liệu.

chucuoi92 · 1/8/18

danghoan83 đã viết:
Cảm ơn bạn nhiều. Rất oke.

Bài đã được tự động gộp: 31/7/18

...Bạn sắp dữ liệu tăng dần (trong mỗi cell cột G) dùm mình luôn được không.

Sort cả dòng và trong cells hả bạn ?
Bạn dùng thử code thô này xem sao , nếu dữ liệu thật có khác cấu trúc thì tự sửa code nhé.

Sub LietKe()
Dim d As Object, d2 As Object
Dim data As Range, cll As Range, i As Long, k As Long
Dim ma As String
Set d = CreateObject("System.collections.sortedlist")
Set d2 = CreateObject("Scripting.Dictionary")
Set data = Sheet1.Range("B2:C5")
For Each cll In data
ma = Right(cll, 1) & Mid(cll, 2, 1) & cll.Row & cll.Column
If d.Contains(ma) = False Then
d.Add ma, cll
End If
Next

For i = 0 To d.Count - 1
If Not d2.exists(Left(d.getkey(i), 1)) Then
k = k + 1
d2.Add Left(d.getkey(i), 1), k
Sheet1.Range("F1").Offset(k) = Left(d.getkey(i), 1)
Sheet1.Range("G1").Offset(k) = Left(d.GetByIndex(i), 2)
Else
Sheet1.Range("G1").Offset(d2.Item(Left(d.getkey(i), 1))) = Sheet1.Range("G1").Offset(d2.Item(Left(d.getkey(i), 1))) & "," & Left(d.GetByIndex(i), 2)
End If
Next

End Sub

sửa bỏ dic

PHP:

Sub LietKe()
Dim d As Object, d2 As Object
Dim data As Range, cll As Range, i As Long, k As Long
Dim ma As String
Set d = CreateObject("System.collections.sortedlist")
Set data = Sheet1.Range("B2:C5")
For Each cll In data
   ma = Right(cll, 1) & Mid(cll, 2, 1) & cll.Row & cll.Column
  If d.Contains(ma) = False Then
    d.Add ma, cll
  End If
Next
For i = 0 To d.Count - 1
    If Sheet1.Range("F1").Offset(k) <> Left(d.getkey(i), 1) Then
         k = k + 1
           Sheet1.Range("F1").Offset(k) = Left(d.getkey(i), 1)
           Sheet1.Range("G1").Offset(k) = Left(d.GetByIndex(i), 2)
         Else
           Sheet1.Range("G1").Offset(k) = Sheet1.Range("G1").Offset(k) & "," & Left(d.GetByIndex(i), 2)
    End If
Next
End Sub

ndu96081631 · 1/8/18

Nếu không cần sắp xếp thì chỉ cần 1 vòng lập + 1 dictionary là đủ

Mã:

Private Sub SpecialReport(ByVal SourceRange As Range, Target As Range)
  Dim aSource   As Variant
  Dim vItem     As Variant
  Dim aTmp      As Variant
  Dim dicKey    As Variant
  Dim dicItem   As Variant
  Dim dic       As Object
  Dim idx       As Long
  aSource = SourceRange.Value
  ReDim aDest(1 To SourceRange.Count, 1 To 2)
  Set dic = CreateObject("Scripting.Dictionary")
  For Each vItem In aSource
    If InStr(1, CStr(vItem), vbLf) Then
      aTmp = Split(vItem, vbLf)
      dicKey = aTmp(1)
      dicItem = aTmp(0)
      If Not dic.Exists(dicKey) Then
        idx = idx + 1
        dic.Add dicKey, idx
        aDest(idx, 1) = dicKey
        aDest(idx, 2) = dicItem
      Else
        aDest(dic.item(dicKey), 2) = aDest(dic.item(dicKey), 2) & ", " & dicItem
      End If
    End If
  Next
  If idx Then Target.Resize(idx, 2).Value = aDest
End Sub
Sub Test()
  SpecialReport Range("B1:D10"), Range("J2")
End Sub

- Việc sắp xếp cho cột thứ nhất: có thể giao cho công cụ Sort xử lý
- Việc sắp xếp cho cột thứ hai: Được nhưng hơi phiền (dùng phương pháp sort mảng). Đây có thể là nguyên nhân khiến tốc độ tính toán giảm đáng kể

excel_lv1.5 · 1/8/18

danghoan83 đã viết:
Cảm ơn bạn nhiều. Rất oke.

Bài đã được tự động gộp: 31/7/18

Cảm ơn bạn. Rất tuyệt. Bạn sắp dữ liệu tăng dần (trong mỗi cell cột G) dùm mình luôn được không.

Chỉnh cho bạn thêm sort trong mỗi cell ở cột G, và sort luôn ở cột F:

PHP:

Sub a()
Dim rng As Range, dic As Object, dic2 As Object, cell As Range, arr(), i As Long
Set rng = Range("B2:C" & [b10000].End(xlUp).Row)
Set dic = CreateObject("Scripting.dictionary")
Set dic2 = CreateObject("Scripting.dictionary")
For Each cell In rng
    If Not dic.Exists(cell) Then dic.Add cell, ""
Next
For Each Key In dic.keys()
    If Not dic2.Exists(Split(Key, ChrW(10))(1)) Then
        dic2.Add Split(Key, ChrW(10))(1), Split(Key, ChrW(10))(0)
    Else
        dic2.Item(Split(Key, ChrW(10))(1)) = dic2.Item(Split(Key, ChrW(10))(1)) & "," & Split(Key, ChrW(10))(0)
    End If
Next
ReDim arr(1 To dic2.Count, 1 To 2)
For i = 0 To dic2.Count - 1
    arr(i + 1, 1) = dic2.keys()(i): arr(i + 1, 2) = sortstr(dic2.items()(i))
Next i
[f2].Resize(UBound(arr), 2) = arr
Range("f2").CurrentRegion.Sort key1:=Range("F2"), _
      order1:=xlAscending, Header:=xlNo
Set dic = Nothing:  Set dic2 = Nothing
End Sub
Function sortstr(ByVal str As String) As String
Dim sval, arr, i%, j%
arr = Split(str, ",")
For i = 0 To UBound(arr) - 1
    For j = i To UBound(arr) - 1
        sval = arr(i)
        If arr(i) > arr(j + 1) Then
            arr(i) = arr(j + 1)
            arr(j + 1) = sval
        End If
    Next
Next
sortstr = Join(arr, ",")
End Function

ndu96081631 · 1/8/18

excel_lv1.5 đã viết:

Chỉnh cho bạn thêm sort trong mỗi cell ở cột G, và sort luôn ở cột F:

PHP:

Option Base 1
Sub a()
Dim rng As Range, dic As Object, dic2 As Object, cell As Range, arr(), i As Long
Set rng = Range("B2:C" & [b10000].End(xlUp).Row)
Set dic = CreateObject("Scripting.dictionary")
Set dic2 = CreateObject("Scripting.dictionary")
For Each cell In rng
    If Not dic.Exists(cell) Then dic.Add cell, ""
Next
For Each Key In dic.keys()
    If Not dic2.Exists(Split(Key, ChrW(10))(1)) Then
        dic2.Add Split(Key, ChrW(10))(1), Split(Key, ChrW(10))(0)
    Else
        dic2.Item(Split(Key, ChrW(10))(1)) = dic2.Item(Split(Key, ChrW(10))(1)) & "," & Split(Key, ChrW(10))(0)
    End If
Next
ReDim arr(1 To dic2.Count, 1 To 2)
For i = 0 To dic2.Count - 1
    arr(i + 1, 1) = dic2.keys()(i): arr(i + 1, 2) = sortstr(dic2.items()(i))
Next i
[f2].Resize(UBound(arr), 2) = arr
Range("f2").CurrentRegion.Sort key1:=Range("F2"), _
      order1:=xlAscending, Header:=xlNo
Set dic = Nothing:  Set dic2 = Nothing
End Sub
Function sortstr(ByVal str As String) As String
Dim sval, arr, i%, j%
arr = Split(str, ",")
For i = 1 To UBound(arr) - 1
    For j = i To UBound(arr) - 1
        sval = arr(i)
        If arr(i) > arr(j + 1) Then
            arr(i) = arr(j + 1)
            arr(j + 1) = sval
        End If
    Next
Next
sortstr = Join(arr, ",")
End Function

Sortstr chỉ áp dụng được cho bài này. Bởi nếu muốn làm 1 hàm tổng quát thì:
- Hàm phải có đối số Delimiter cho phép chọn dấu phân cách là gì
- Nếu bỏ qua đối số Delimiter có nghĩa là ta muốn sort từng ký tự trong chuỗi
- Sort mảng theo kiểu duyệt 2 vòng lập hình như tốn rất nhiều năng lượng. Hiện tại có rất nhiều công cụ hỗ trợ mà ta có thể áp dụng, chẳng hạn như SortedList hay JavaScript

excel_lv1.5 · 1/8/18

ndu96081631 đã viết:
Sortstr chỉ áp dụng được cho bài này. Bởi nếu muốn làm 1 hàm tổng quát thì:
- Hàm phải có đối số Delimiter cho phép chọn dấu phân cách là gì
- Nếu bỏ qua đối số Delimiter có nghĩa là ta muốn sort từng ký tự trong chuỗi
- Sort mảng theo kiểu duyệt 2 vòng lập hình như tốn rất nhiều năng lượng. Hiện tại có rất nhiều công cụ hỗ trợ mà ta có thể áp dụng, chẳng hạn như SortedList hay JavaScript

Tại thấy có bạn làm sortedlist rồi, nên làm theo hướng này, thì như bạn nói chỉ áp dụng cho bài này thôi

.

dazkangel · 1/8/18

Phan Thế Hiệp đã viết:
"A,B,C,D" nữa em! không có sẵn, và cũng được sắp xếp theo alphabet, vậy mới vui!
Chúc em ngày vui.

Nay rảnh ngồi mò thử, chỉ dành cho 1 ký tự:

Mã:

B8=CHAR(AGGREGATE(15,6,CODE(RIGHT(B$2:C$5))/(COUNTIF(B$7:B7,RIGHT(B$2:C$5))=0),1))

Tự động liệt kê và sắp xếp dữ liệu

danghoan83

Thành viên chính thức

File đính kèm

dazkangel

<New Horizons>

File đính kèm

Phan Thế Hiệp

-⍟-

truongvu317

Thành viên tích cực

vanaccex

Thành viên tiêu biểu

truongvu317

Thành viên tích cực

excel_lv1.5

Thành viên tích cực

File đính kèm

danghoan83

Thành viên chính thức

befaint

|||||||||||||

chucuoi92

Thành viên lười biếng

File đính kèm

ndu96081631

Huyền thoại GPE

excel_lv1.5

Thành viên tích cực

ndu96081631

Huyền thoại GPE

excel_lv1.5

Thành viên tích cực

dazkangel

<New Horizons>

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng