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

Liên hệ QC
D

danghoan83

Thành viên chính thức
Tham gia
23/12/09
Bài viết
54
Được thích
0
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.
 

File đính kèm

  • lietke.xlsx
    11.1 KB · Đọc: 32
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.
Nhấp chuột vào đây để mở rộng...
Làm thử 1 tí, nhớ vào File/Excel Option/Formulas chọn Enable iterative calculation:
 

File đính kèm

  • lietke.xlsx
    11.2 KB · Đọc: 25
Đưa file thật, dữ liệu thật lên, dùng vba cũng mướt mồ hôi luôn.
 
Chắc cần phải tách ra dữ liệu dạng chuẩn rồ mới ghép được
 
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.
Nhấp chuột vào đây để mở rộng...
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
 

File đính kèm

  • lietke (1).xls
    43 KB · Đọc: 18
Lần chỉnh sửa cuối:
dazkangel đã viết:
Làm thử 1 tí, nhớ vào File/Excel Option/Formulas chọn Enable iterative calculation:
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn nhiều. Rất oke.
Bài đã được tự động gộp:

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
Nhấp chuột vào đây để mở rộng...
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.
 
Lần chỉnh sửa cuối:
danghoan83 đã viết:
Cảm ơn bạn nhiều. Rất oke.
Bài đã được tự động gộp:


...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.
Nhấp chuột vào đây để mở rộ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
Nhấp chuột vào đây để mở rộng...
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
 

File đính kèm

  • lietke.xlsm
    21 KB · Đọc: 9
Lần chỉnh sửa cuối:
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ể
 
Lần chỉnh sửa cuối:
danghoan83 đã viết:
Cảm ơn bạn nhiều. Rất oke.
Bài đã được tự động gộp:


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.
Nhấp chuột vào đây để mở rộ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
 
Lần chỉnh sửa cuối:
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
Nhấp chuột vào đây để mở rộng...
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
 
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
Nhấp chuột vào đây để mở rộng...
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 :).
 
Lần chỉnh sửa cuối:
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

dunghtgiga
Không cho người khác chỉnh sửa nội dung bảng tính
Trả lời
4
Đọc
101
VetMini
V
H
Tính tổng có điều kiện
Trả lời
18
Đọc
271
VetMini
V
vova2209
Hàm if điều kiện mảng
Trả lời
18
Đọc
330
VetMini
V
T
Thống kê ngày hết hạn của sản phẩm
Trả lời
12
Đọc
236
VetMini
V
T
tự động giãn dòng theo dữ liệu
    • Buồn
Trả lời
3
Đọc
56
VetMini
V
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom