Sắp xếp các hàng theo hoán vị của 3 giá trị

Liên hệ QC
T

tunglinhmot

Thành viên chính thức
Tham gia
17/5/17
Bài viết
59
Được thích
6
Giới tính
Nam
Em có một file dữ liệu có các giá trị trong các côt H, I, J như file đính kèm. Em cần một chương trình có thế sắp xếp các hàng theo tổ hợp 3 giá trị trong 3 cột H, I, J. Ví dụ tất cả các hàng mà chứa các giá trị a, b, c nằm ở 3 cột H, I, J sẽ được sắp xếp liền nhau mà không quan tâm đến thứ tự là abc, bca, hay là cab... đồng thời đánh số thứ tự từ 1 đến hết cho các tổ hợp liền nhau sau khi sắp xếp vào cột Q.
Lúc sắp xếp các hàng thì tất các các giá trị trong hàng từ cột A đến cột T cũng phải đi theo nữa.
Mong các anh em trong group giúp đỡ. Em xin cảm ơn ạ.
Trong file đính kèm thì sheet1 là dữ liệu ban đầu, sheet2 là phần mong muốn sau khi chạy ạ.
 

File đính kèm

  • file mau.xlsm
    40.8 KB · Đọc: 23
Sắp xếp theo thời gian sắp xếp theo bầu chọn
tunglinhmot đã viết:
Trong file đính kèm thì sheet1 là dữ liệu ban đầu, sheet2 là phần mong muốn sau khi chạy ạ.
Nhấp chuột vào đây để mở rộng...
Làm gì có chuyện đó.

Trong Sheet2 ở H, I, J có (tương ứng ở Q là 2, 2, 2)
D P H
D H P
D H P

Nhưng nếu mắt tôi vẫn còn tốt thì trong sheet1 chỉ có dòng 4 với
D P H

Tìm mỏi mắt không có dòng nào có
D H P

Tương tự trong sheet1 chỉ có dòng 7 với
D Q W

làm gì có
D Q W - lần thứ 2
W Q D

Vân vân và mây mây.
 
Upvote 0
batman1 đã viết:
Làm gì có chuyện đó.

Trong Sheet2 ở H, I, J có (tương ứng ở Q là 2, 2, 2)
D P H
D H P
D H P

Nhưng nếu mắt tôi vẫn còn tốt thì trong sheet1 chỉ có dòng 4 với
D P H

Tìm mỏi mắt không có dòng nào có
D H P

Tương tự trong sheet1 chỉ có dòng 7 với
D Q W

làm gì có
D Q W - lần thứ 2
W Q D

Vân vân và mây mây.
Nhấp chuột vào đây để mở rộng...
Cái này em chỉ lấy ví dụ là sau khi chạy xong nó ra kiểu như thế bác ạ, tất cả các tổ hợp cùng chứa 3 giá trị nào đó thì đánh số thứ tự giống nhau như vậy ạ.
 
Upvote 0
Xài đỡ cái này trong khi chờ phương án khác nhanh hơn và ngắn gọn hơn:
PHP: 
Option Explicit
Sub sapxep()
Dim lr&, t&, i&, j&, m&, c&, rng, arr(), id As String
Dim dic As Object, key
Application.ScreenUpdating = False
Set dic = CreateObject("scripting.dictionary")
lr = Cells(Rows.Count, "H").End(xlUp).Row
rng = Range("H2:T" & lr).Value
For t = 1 To lr - 1
    c = c + 1
    For i = 1 To 3
        For j = 1 To 3
            For m = 1 To 3
                id = rng(t, i) & rng(t, j) & rng(t, m)
                If i <> j And i <> m And j <> m And Not dic.exists(id) Then
                    dic.Add id, c
                End If
            Next
        Next
    Next
Next
ReDim arr(1 To dic.Count, 1 To 1)
For Each key In dic.keys
    For i = 1 To lr - 1
        id = rng(i, 1) & rng(i, 2) & rng(i, 3)
        If id Like key Then arr(i, 1) = dic(key)
    Next
Next
Range("Q2").Resize(UBound(arr), 1).Value = arr
Range("A2:T" & lr).Sort Range("Q1")
rng = Range("Q2:Q" & lr).Value
ReDim arr(1 To lr - 1, 1 To 1)
arr(1, 1) = rng(1, 1): j = 1
For i = 2 To lr - 1
    If rng(i, 1) = rng(i - 1, 1) Then
        arr(i, 1) = arr(i - 1, 1)
    Else
        j = j + 1
        arr(i, 1) = j
    End If
Next
Range("Q2:Q" & lr).Value = arr
Set dic = Nothing
Application.ScreenUpdating = True
End Sub
 

File đính kèm

  • file mau.xlsm
    61.8 KB · Đọc: 15
Upvote 0
bebo021999 đã viết:
Xài đỡ cái này trong khi chờ phương án khác nhanh hơn và ngắn gọn hơn:
PHP: 
Option Explicit
Sub sapxep()
Dim lr&, t&, i&, j&, m&, c&, rng, arr(), id As String
Dim dic As Object, key
Application.ScreenUpdating = False
Set dic = CreateObject("scripting.dictionary")
lr = Cells(Rows.Count, "H").End(xlUp).Row
rng = Range("H2:T" & lr).Value
For t = 1 To lr - 1
    c = c + 1
    For i = 1 To 3
        For j = 1 To 3
            For m = 1 To 3
                id = rng(t, i) & rng(t, j) & rng(t, m)
                If i <> j And i <> m And j <> m And Not dic.exists(id) Then
                    dic.Add id, c
                End If
            Next
        Next
    Next
Next
ReDim arr(1 To dic.Count, 1 To 1)
For Each key In dic.keys
    For i = 1 To lr - 1
        id = rng(i, 1) & rng(i, 2) & rng(i, 3)
        If id Like key Then arr(i, 1) = dic(key)
    Next
Next
Range("Q2").Resize(UBound(arr), 1).Value = arr
Range("A2:T" & lr).Sort Range("Q1")
rng = Range("Q2:Q" & lr).Value
ReDim arr(1 To lr - 1, 1 To 1)
arr(1, 1) = rng(1, 1): j = 1
For i = 2 To lr - 1
    If rng(i, 1) = rng(i - 1, 1) Then
        arr(i, 1) = arr(i - 1, 1)
    Else
        j = j + 1
        arr(i, 1) = j
    End If
Next
Range("Q2:Q" & lr).Value = arr
Set dic = Nothing
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Sẽ có những trường hợp dữ liệu code chạy có lỗi. Vd. dữ liệu như sau

hoanvi3.png
 
Upvote 0
Upvote 0
bebo021999 đã viết:
Xài đỡ cái này trong khi chờ phương án khác nhanh hơn và ngắn gọn hơn:
PHP: 
Option Explicit
Sub sapxep()
Dim lr&, t&, i&, j&, m&, c&, rng, arr(), id As String
Dim dic As Object, key
Application.ScreenUpdating = False
Set dic = CreateObject("scripting.dictionary")
lr = Cells(Rows.Count, "H").End(xlUp).Row
rng = Range("H2:T" & lr).Value
For t = 1 To lr - 1
    c = c + 1
    For i = 1 To 3
        For j = 1 To 3
            For m = 1 To 3
                id = rng(t, i) & rng(t, j) & rng(t, m)
                If i <> j And i <> m And j <> m And Not dic.exists(id) Then
                    dic.Add id, c
                End If
            Next
        Next
    Next
Next
ReDim arr(1 To dic.Count, 1 To 1)
For Each key In dic.keys
    For i = 1 To lr - 1
        id = rng(i, 1) & rng(i, 2) & rng(i, 3)
        If id Like key Then arr(i, 1) = dic(key)
    Next
Next
Range("Q2").Resize(UBound(arr), 1).Value = arr
Range("A2:T" & lr).Sort Range("Q1")
rng = Range("Q2:Q" & lr).Value
ReDim arr(1 To lr - 1, 1 To 1)
arr(1, 1) = rng(1, 1): j = 1
For i = 2 To lr - 1
    If rng(i, 1) = rng(i - 1, 1) Then
        arr(i, 1) = arr(i - 1, 1)
    Else
        j = j + 1
        arr(i, 1) = j
    End If
Next
Range("Q2:Q" & lr).Value = arr
Set dic = Nothing
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Em cảm ơn bác, nhưng phần khai báo ReDim arr(1 To dic.Count, 1 To 1) này thì sẽ gặp lỗi nếu dữ liệu có từ 1000, 2000 dòng trở lên, bác có thể chỉnh lại giúp em để code chạy được với dữ liệu lớn được không ạ.
 
Upvote 0
tunglinhmot đã viết:
Cái này em chỉ lấy ví dụ là sau khi chạy xong nó ra kiểu như thế bác ạ, tất cả các tổ hợp cùng chứa 3 giá trị nào đó thì đánh số thứ tự giống nhau như vậy ạ.
Nhấp chuột vào đây để mở rộng...

Vì bạn đưa kết quả mẫu không chính xác, kiểu làm cho lấy có, nên một số người không muốn trợ giúp.

Mỗi người có cách tiếp cận và giải quyết 1 vấn đề là khác nhau, nên code khác nhau về độ dài, tốc độ ...

Có thể chỉ cần dùng 3 vòng For.

Úp giùm bạn.

.
 
Upvote 0
Thanks bác @batman1 đã chỉ ra lỗi.
@tunglinhmot sửa lại như sau:
Thay:
Mã: 
ReDim arr(1 To dic.Count, 1 To 1)
bằng
Mã: 
ReDim arr(1 To lr - 1, 1 To 1)
 
Upvote 0
tunglinhmot đã viết:
Em có một file dữ liệu có các giá trị trong các côt H, I, J như file đính kèm. Em cần một chương trình có thế sắp xếp các hàng theo tổ hợp 3 giá trị trong 3 cột H, I, J. Ví dụ tất cả các hàng mà chứa các giá trị a, b, c nằm ở 3 cột H, I, J sẽ được sắp xếp liền nhau mà không quan tâm đến thứ tự là abc, bca, hay là cab... đồng thời đánh số thứ tự từ 1 đến hết cho các tổ hợp liền nhau sau khi sắp xếp vào cột Q.
Lúc sắp xếp các hàng thì tất các các giá trị trong hàng từ cột A đến cột T cũng phải đi theo nữa.
Mong các anh em trong group giúp đỡ. Em xin cảm ơn ạ.
Trong file đính kèm thì sheet1 là dữ liệu ban đầu, sheet2 là phần mong muốn sau khi chạy ạ.
Nhấp chuột vào đây để mở rộng...
Thử code sau.
Mã: 
Sub abc()
    Dim i As Long, arr, dic As Object, dk As String, ketqua, ketqua1
    Dim T, b As Long, lr As Long, data, a As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("sheet1")
         lr = .Range("H" & Rows.Count).End(xlUp).Row
         arr = .Range("H2:J" & lr).Value
         data = .Range("T2:T" & lr).Value
         ReDim kq(1 To UBound(arr), 1 To 2)
         ReDim ketqua(1 To UBound(arr), 1 To 3)
         ReDim ketqua1(1 To UBound(arr), 1 To 4)
    End With
         For i = 1 To UBound(arr)
             dk = xapxep(Array(arr(i, 1), arr(i, 2), arr(i, 3)))
             If Not dic.exists(dk) Then
                a = a + 1
                dic.Add dk, i
                kq(a, 1) = a
                kq(a, 2) = dk
             Else
                dic.Item(dk) = dic.Item(dk) & "#" & i
             End If
         Next i
         For i = 1 To a
             dk = kq(i, 2)
             For Each T In Split(dic.Item(dk), "#")
                 b = b + 1
                 ketqua(b, 1) = arr(T, 1)
                 ketqua(b, 2) = arr(T, 2)
                 ketqua(b, 3) = arr(T, 3)
                 ketqua1(b, 1) = i
                 ketqua1(b, 4) = data(T, 1)
             Next
         Next i
    With Sheets("sheet2")
         lr = .Range("H" & Rows.Count).End(xlUp).Row
         If lr > 1 Then .Range("H2:J" & lr).ClearContents: .Range("Q2:T" & lr).ClearContents
         .Range("H2:J2").Resize(b).Value = ketqua
         .Range("Q2:T2").Resize(b).Value = ketqua1
    End With
    Set dic = Nothing
End Sub
Private Function xapxep(arr) As String
        Dim T As String, i As Long, j As Long
        For i = 0 To UBound(arr)
            For j = i + 1 To UBound(arr)
                 If arr(i) > arr(j) Then
                    T = arr(j)
                    arr(j) = arr(i)
                    arr(i) = T
                 End If
            Next j
        Next i
        xapxep = Join(arr, "")
End Function
 
Upvote 0
tunglinhmot đã viết:
Em có một file dữ liệu có các giá trị trong các côt H, I, J như file đính kèm. Em cần một chương trình có thế sắp xếp các hàng theo tổ hợp 3 giá trị trong 3 cột H, I, J. Ví dụ tất cả các hàng mà chứa các giá trị a, b, c nằm ở 3 cột H, I, J sẽ được sắp xếp liền nhau mà không quan tâm đến thứ tự là abc, bca, hay là cab... đồng thời đánh số thứ tự từ 1 đến hết cho các tổ hợp liền nhau sau khi sắp xếp vào cột Q.
Lúc sắp xếp các hàng thì tất các các giá trị trong hàng từ cột A đến cột T cũng phải đi theo nữa.
Mong các anh em trong group giúp đỡ. Em xin cảm ơn ạ.
Trong file đính kèm thì sheet1 là dữ liệu ban đầu, sheet2 là phần mong muốn sau khi chạy ạ.
Nhấp chuột vào đây để mở rộng...
"Lúc sắp xếp các hàng thì tất các các giá trị trong hàng từ cột A đến cột T cũng phải đi theo"
Góp vui
Mã: 
Sub XYZ()
  Dim arr(), res(), b, S, dic As Object, key
  Dim sRow&, sCol&, i&, iR&, k&, j&, stt&
 
  b = Array(0, 1, 0, 2, 1, 2)
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("sheet1")
    arr = .Range("A2", .Range("T" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(arr): sCol = UBound(arr, 2)
  ReDim res(1 To sRow, 1 To sCol)
  For i = 1 To sRow
    Call XepThuTu(key, b, Array(arr(i, 8), arr(i, 9), arr(i, 10)))
    dic.iTem(key) = dic.iTem(key) & "|" & i
  Next i
  For Each key In dic.keys
    stt = stt + 1
    S = Split(dic.iTem(key), "|")
    For i = 1 To UBound(S)
      k = k + 1
      iR = S(i)
      For j = 1 To sCol
        res(k, j) = arr(iR, j)
      Next j
      res(k, 17) = stt
    Next i
  Next
  With Sheets("sheet2")
    i = .Range("T" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("A2:T" & i).ClearContents
    .Range("A2").Resize(sRow, sCol).Value = res
  End With
End Sub

Private Sub XepThuTu(key, b, ByVal arr)
  Dim tmp$, i&, j&
  For i = 0 To UBound(b) Step 2
    If arr(b(i)) > arr(b(i + 1)) Then
      tmp = arr(b(i + 1))
      arr(b(i + 1)) = arr(b(i))
      arr(b(i)) = tmp
    End If
  Next i
  key = Join(arr, "|")
End Sub
 
Upvote 0
HieuCD đã viết:
"Lúc sắp xếp các hàng thì tất các các giá trị trong hàng từ cột A đến cột T cũng phải đi theo"
Góp vui
Mã: 
Sub XYZ()
  Dim arr(), res(), b, S, dic As Object, key
  Dim sRow&, sCol&, i&, iR&, k&, j&, stt&
 
  b = Array(0, 1, 0, 2, 1, 2)
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("sheet1")
    arr = .Range("A2", .Range("T" & Rows.Count).End(xlUp)).Value
  End With
  sRow = UBound(arr): sCol = UBound(arr, 2)
  ReDim res(1 To sRow, 1 To sCol)
  For i = 1 To sRow
    Call XepThuTu(key, b, Array(arr(i, 8), arr(i, 9), arr(i, 10)))
    dic.iTem(key) = dic.iTem(key) & "|" & i
  Next i
  For Each key In dic.keys
    stt = stt + 1
    S = Split(dic.iTem(key), "|")
    For i = 1 To UBound(S)
      k = k + 1
      iR = S(i)
      For j = 1 To sCol
        res(k, j) = arr(iR, j)
      Next j
      res(k, 17) = stt
    Next i
  Next
  With Sheets("sheet2")
    i = .Range("T" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("A2:T" & i).ClearContents
    .Range("A2").Resize(sRow, sCol).Value = res
  End With
End Sub

Private Sub XepThuTu(key, b, ByVal arr)
  Dim tmp$, i&, j&
  For i = 0 To UBound(b) Step 2
    If arr(b(i)) > arr(b(i + 1)) Then
      tmp = arr(b(i + 1))
      arr(b(i + 1)) = arr(b(i))
      arr(b(i)) = tmp
    End If
  Next i
  key = Join(arr, "|")
End Sub
Nhấp chuột vào đây để mở rộng...
Code không chạy được bác ạ, với cả dữ liệu của em chỉ trong 1 Sheet thôi ạ, bác khai báo With Sheets("sheet2") để mục đích làm gì ạ, em không hiểu chỗ này lắm
 
Upvote 0
tunglinhmot đã viết:
Code không chạy được bác ạ, với cả dữ liệu của em chỉ trong 1 Sheet thôi ạ, bác khai báo With Sheets("sheet2") để mục đích làm gì ạ, em không hiểu chỗ này lắm
Nhấp chuột vào đây để mở rộng...
"Trong file đính kèm thì sheet1 là dữ liệu ban đầu, sheet2 là phần mong muốn sau khi chạy ạ"
Sheet2 là nơi gán kết quả
"Code không chạy được bác ạ" không chạy được là như thế nào? xóa toàn bộ dữ liệu sheet2 rồi chạy code
 
Upvote 0
tunglinhmot đã viết:
dữ liệu của em chỉ trong 1 Sheet thôi
Nhấp chuột vào đây để mở rộng...
Code này dùng Sort trên Range, nên có thể chậm nhưng đơn giản:

PHP: 
Public Sub SapXep()
Dim dic As Object, Sarr As Variant, Darr As Variant
Dim r&, c&, cc&, k&, ID$, temp$
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
    r = .Range("H" & .Rows.Count).End(xlUp).Row
    Sarr = .Range("H2:J" & r).Value
    ReDim Darr(1 To UBound(Sarr, 1), 1 To 1)
        For r = 1 To UBound(Sarr, 1)
            'sort and join
            For c = 1 To 2
                For cc = c + 1 To 3
                    If Sarr(r, c) > Sarr(r, cc) Then
                        temp = Sarr(r, c)
                        Sarr(r, c) = Sarr(r, cc)
                        Sarr(r, cc) = temp
                    End If
                Next cc
            Next c
            ID = Sarr(r, 1) & "|" & Sarr(r, 2) & "|" & Sarr(r, 3)
            'end sort and join
            'Kiem tra
            If dic.exists(ID) = False Then
                k = k + 1
                dic.Add ID, k
            End If
            'Ghi so Thu tu
            Darr(r, 1) = dic.Item(ID)
        Next r
        .Range("Q2").Resize(r - 1, 1).Value = Darr
        .Range("A2:T" & r - 1).Sort Key1:=.Range("Q2"), Order1:=xlAscending, Header:=xlNo
End With

End Sub
 
Upvote 0
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

thlpro
Truy Vấn Công thức từ Sheet này Qua Sheet Khác
Trả lời
0
Đọc
1
thlpro
thlpro
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
7 8 9
Trả lời
179
Đọc
9K
ongke0711
ongke0711
B
Sắp xếp lịch trực
5 6 7
Trả lời
130
Đọc
86K
TTVAN28
TTVAN28
N
Giúp em hàm Aggregate không chạy được trên Google sheet ah
Trả lời
4
Đọc
106
nguyenthieny
N
hunganh.nguyen
Xin giúp code tách dòng tổng thành những dòng chi tiết với giá trị là 1
Trả lời
8
Đọc
374
DeTong
D
S
Chuyển định dạng thời gian từ sa/ch sang AM/PM
Trả lời
1
Đọc
25
bebo021999
B
N
  • Question
VBA - copy các sheets unhide và dạng giá trị theo vùng xác định
Trả lời
2
Đọc
36
bebo021999
B
hoaithanh9480
Nhờ giúp đỡ về kiểm phiếu bầu
Trả lời
4
Đọc
52
hoaithanh9480
hoaithanh9480
B
Nhờ anh/chị giúp em tìm hàm cho công thức tính lương
Trả lời
2
Đọc
94
hoangtuaotrang_hp_vn
H
SA_DQ
Phẩu thuật Nụ cười lần 3 tại Huế.
    • Thích
    • Yêu thích
Trả lời
1
Đọc
70
HUONGHCKT
H
K
  • Question
Sử dụng Power Query để xử lý nhật ký chung nhiều nợ nhiều có
    • Cười
Trả lời
14
Đọc
268
viethung78
V
N
cộng các dữ liệu không trùng nhau
Trả lời
13
Đọc
220
DeTong
D
T
Lỗi import dữ liệu
Trả lời
1
Đọc
28
ongke0711
ongke0711
Huy@@*
Giải đáp giùm em, cách khắc phục lỗi này trên VBA
2
Trả lời
28
Đọc
363
ptm0412
ptm0412
E
  • Question
Tạo bảng lọc theo điều kiện
Trả lời
7
Đọc
141
Hoàng Tuấn 868
H
Bùi Thúy Thúy
  • Question
Lấy dữ liệu thời tiết Accuweather để điền vào nhật ký thi công
2 3 4
Trả lời
62
Đọc
18K
HeSanbi
HeSanbi
vova2209
Index kết hợp với match 2 điều kiện
Trả lời
14
Đọc
1K
dunghtgiga
dunghtgiga
D
  • Question
Xin cách tạo tab và button cho Add-in trên ribbon Maintabs
Trả lời
2
Đọc
103
Decepticon
D
T
Chèn dữ liệu từ sheet này qua sheet khác theo điều kiện
Trả lời
3
Đọc
146
HieuCD
H
T
Trùng 2 lần: Tìm dữ liệu nhiều điều kiện
Trả lời
0
Đọc
88
Thulib
T
Xem thêm…

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