viết code giúp chức năng sort dữ liệu có điều kiện

Liên hệ QC
T

Thuy.Vuong

Thành viên mới
Tham gia
25/12/21
Bài viết
24
Được thích
0
Giới tính
Nữ
Em chào anh chị!
Em có một file cần lọc dữ liệu theo cấp độ ưu tiên, khi nhấn vào nút "Lọc Dữ Liệu" thì dữ liệu từ cột A4 đến đến cột AE sẽ được sắp xếp theo cấp độ ưu tiên như em đã để số thứ tự 1(F2), 2(H2), 3(J2), 4(P2), 5(O2), kiểu sắp xếp là từ A-Z, nếu cột là số thì sắp xêp từ bé đến lớn, hiện tại thì em đang sử dụng chức năng sort của excel như hình ảnh bên dưới , nhưng khi cần thiết thập thêm mức độ ưu tiên cho các cột khác thì rất dễ bị nhầm lẫn mất kiểm soát không thể nhớ được là đã sort hay chưa, vì vậy rất mong a chị viết code giúp em vấn đề này.

Capture.PNG
 

File đính kèm

  • Loc Du Lieu.xlsb
    33.5 KB · Đọc: 23
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Thuy.Vuong đã viết:
Em chào anh chị!
Em có một file cần lọc dữ liệu theo cấp độ ưu tiên, khi nhấn vào nút "Lọc Dữ Liệu" thì dữ liệu từ cột A4 đến đến cột AE sẽ được sắp xếp theo cấp độ ưu tiên như em đã để số thứ tự 1(F2), 2(H2), 3(J2), 4(P2), 5(O2), kiểu sắp xếp là từ A-Z, nếu cột là số thì sắp xêp từ bé đến lớn, hiện tại thì em đang sử dụng chức năng sort của excel như hình ảnh bên dưới , nhưng khi cần thiết thập thêm mức độ ưu tiên cho các cột khác thì rất dễ bị nhầm lẫn mất kiểm soát không thể nhớ được là đã sort hay chưa, vì vậy rất mong a chị viết code giúp em vấn đề này.

View attachment 271843
Nhấp chuột vào đây để mở rộng...
Dùng bộ thu Macro, tùy chỉnh thêm dòng cuối "eRow"
Mã: 
Sub ABC()
    Dim eRow As Long
    eRow = Worksheets("ABS").Range("D" & Rows.Count).End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co du lieu!"): Exit Sub
    ActiveWorkbook.Worksheets("ABS").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("ABS").Sort.SortFields.Add Key:=Range("F4:F" & eRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("ABS").Sort.SortFields.Add Key:=Range("H4:H" & eRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("ABS").Sort.SortFields.Add Key:=Range("J4:J" & eRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("ABS").Sort.SortFields.Add Key:=Range("P4:P" & eRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("ABS").Sort.SortFields.Add Key:=Range("O4:O" & eRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("ABS").Sort
        .SetRange Range("A3:AR" & eRow) 'Sort tu cot A toi cot AR
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
 
Upvote 0
HieuCD đã viết:
Dùng bộ thu Macro, tùy chỉnh thêm dòng cuối "eRow"
Mã: 
Sub ABC()
    Dim eRow As Long
    eRow = Worksheets("ABS").Range("D" & Rows.Count).End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co du lieu!"): Exit Sub
    ActiveWorkbook.Worksheets("ABS").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("ABS").Sort.SortFields.Add Key:=Range("F4:F" & eRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("ABS").Sort.SortFields.Add Key:=Range("H4:H" & eRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("ABS").Sort.SortFields.Add Key:=Range("J4:J" & eRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("ABS").Sort.SortFields.Add Key:=Range("P4:P" & eRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("ABS").Sort.SortFields.Add Key:=Range("O4:O" & eRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("ABS").Sort
        .SetRange Range("A3:AR" & eRow) 'Sort tu cot A toi cot AR
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
Nhấp chuột vào đây để mở rộng...
A HieuCD ơi code chạy rồi a nhé, nhưng mà mỗi lần muốn thay đổi thứ tự ưu tiên, phải mở code ra sửa mà sửa thì dễ nhầm lẫn lắm ạ, thay vì phải mở code, a có thể viết giúp em chỉ cần thay đổi thứ tự ưu tiên ở các ô
1(F2), 2(H2), 3(J2), 4(P2), 5(O2) được không ạ ví dụ như em muốn đổi thứ tự ưu tiên 1(O2) và 5(F2) sau đó nhấn nút thứ tự ưu tiên sẽ được cập nhật lại
 
Upvote 0
Thuy.Vuong đã viết:
A HieuCD ơi code chạy rồi a nhé, nhưng mà mỗi lần muốn thay đổi thứ tự ưu tiên, phải mở code ra sửa mà sửa thì dễ nhầm lẫn lắm ạ, thay vì phải mở code, a có thể viết giúp em chỉ cần thay đổi thứ tự ưu tiên ở các ô
1(F2), 2(H2), 3(J2), 4(P2), 5(O2) được không ạ ví dụ như em muốn đổi thứ tự ưu tiên 1(O2) và 5(F2) sau đó nhấn nút thứ tự ưu tiên sẽ được cập nhật lại
Nhấp chuột vào đây để mở rộng...
Thuy.Vuong đã viết:
A HieuCD ơi code chạy rồi a nhé, nhưng mà mỗi lần muốn thay đổi thứ tự ưu tiên, phải mở code ra sửa mà sửa thì dễ nhầm lẫn lắm ạ, thay vì phải mở code, a có thể viết giúp em chỉ cần thay đổi thứ tự ưu tiên ở các ô
1(F2), 2(H2), 3(J2), 4(P2), 5(O2) được không ạ ví dụ như em muốn đổi thứ tự ưu tiên 1(O2) và 5(F2) sau đó nhấn nút thứ tự ưu tiên sẽ được cập nhật lại
Nhấp chuột vào đây để mở rộng...
Nhập thứ tự ưu tiên vào A2:AE2, số dương sort A->Z số âm sort Z->A
Mã: 
Option Explicit
Sub XYZ()
  Dim aDK(), arr(), eRow&, sRow&, sCol&, j&, c, ord
  With Worksheets("ABS")
    eRow = .Range("D" & Rows.Count).End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co du lieu!"): Exit Sub
    sRow = eRow - 3
    aDK = .Range("A2:AE2").Value 'Vung dieu kien sort
    Call dkSort(aDK, arr, sCol)
    If sCol > 0 Then
      .Sort.SortFields.Clear
      For j = 1 To sCol
        If arr(1, j) <> Empty Then
          If arr(2, j) > 0 Then ord = 1 Else ord = 2
          .Sort.SortFields.Add Key:=Range(arr(1, j)).Resize(sRow), _
          SortOn:=xlSortOnValues, Order:=ord, DataOption:=xlSortNormal
        End If
      Next j
      With ActiveWorkbook.Worksheets("ABS").Sort
        .SetRange Range("A3:AR" & eRow) 'Sort tu cot A toi cot AR
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
      End With
    End If
  End With
End Sub

Private Sub dkSort(aDK, arr, sCol)
  Dim j&, c, cAbs&
  For j = 1 To UBound(aDK, 2)
    c = aDK(1, j)
    If c <> Empty And IsNumeric(c) Then
      cAbs = Abs(c)
      If sCol < cAbs Then
        sCol = cAbs
        ReDim Preserve arr(1 To 2, 1 To sCol)
      End If
      arr(1, cAbs) = Cells(4, j).Address(0, 0)
      arr(2, cAbs) = c
    End If
  Next j
End Sub
 
Upvote 0
HieuCD đã viết:
Nhập thứ tự ưu tiên vào A2:AE2, số dương sort A->Z số âm sort Z->A
Mã: 
Option Explicit
Sub XYZ()
  Dim aDK(), arr(), eRow&, sRow&, sCol&, j&, c, ord
  With Worksheets("ABS")
    eRow = .Range("D" & Rows.Count).End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co du lieu!"): Exit Sub
    sRow = eRow - 3
    aDK = .Range("A2:AE2").Value 'Vung dieu kien sort
    Call dkSort(aDK, arr, sCol)
    If sCol > 0 Then
      .Sort.SortFields.Clear
      For j = 1 To sCol
        If arr(1, j) <> Empty Then
          If arr(2, j) > 0 Then ord = 1 Else ord = 2
          .Sort.SortFields.Add Key:=Range(arr(1, j)).Resize(sRow), _
          SortOn:=xlSortOnValues, Order:=ord, DataOption:=xlSortNormal
        End If
      Next j
      With ActiveWorkbook.Worksheets("ABS").Sort
        .SetRange Range("A3:AR" & eRow) 'Sort tu cot A toi cot AR
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
      End With
    End If
  End With
End Sub

Private Sub dkSort(aDK, arr, sCol)
  Dim j&, c, cAbs&
  For j = 1 To UBound(aDK, 2)
    c = aDK(1, j)
    If c <> Empty And IsNumeric(c) Then
      cAbs = Abs(c)
      If sCol < cAbs Then
        sCol = cAbs
        ReDim Preserve arr(1 To 2, 1 To sCol)
      End If
      arr(1, cAbs) = Cells(4, j).Address(0, 0)
      arr(2, cAbs) = c
    End If
  Next j
End Sub
Nhấp chuột vào đây để mở rộng...
em cám ơn a nhé, để em copy về chạy
Bài đã được tự động gộp:

Hoàng Tuấn 868 đã viết:
Từ đầu đến giờ không thấy bóng dáng một câu cảm ơn nào cho người giúp nhỉ.
Nhấp chuột vào đây để mở rộng...
vâng, giờ em mới đọc tin của a HieuCD, không cám ơn không được ấy hihihi, cám ơn tất cả các anh nhé
 
Upvote 0
HieuCD đã viết:
Nhập thứ tự ưu tiên vào A2:AE2, số dương sort A->Z số âm sort Z->A
Mã: 
Option Explicit
Sub XYZ()
  Dim aDK(), arr(), eRow&, sRow&, sCol&, j&, c, ord
  With Worksheets("ABS")
    eRow = .Range("D" & Rows.Count).End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co du lieu!"): Exit Sub
    sRow = eRow - 3
    aDK = .Range("A2:AE2").Value 'Vung dieu kien sort
    Call dkSort(aDK, arr, sCol)
    If sCol > 0 Then
      .Sort.SortFields.Clear
      For j = 1 To sCol
        If arr(1, j) <> Empty Then
          If arr(2, j) > 0 Then ord = 1 Else ord = 2
          .Sort.SortFields.Add Key:=Range(arr(1, j)).Resize(sRow), _
          SortOn:=xlSortOnValues, Order:=ord, DataOption:=xlSortNormal
        End If
      Next j
      With ActiveWorkbook.Worksheets("ABS").Sort
        .SetRange Range("A3:AR" & eRow) 'Sort tu cot A toi cot AR
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
      End With
    End If
  End With
End Sub

Private Sub dkSort(aDK, arr, sCol)
  Dim j&, c, cAbs&
  For j = 1 To UBound(aDK, 2)
    c = aDK(1, j)
    If c <> Empty And IsNumeric(c) Then
      cAbs = Abs(c)
      If sCol < cAbs Then
        sCol = cAbs
        ReDim Preserve arr(1 To 2, 1 To sCol)
      End If
      arr(1, cAbs) = Cells(4, j).Address(0, 0)
      arr(2, cAbs) = c
    End If
  Next j
End Sub
Nhấp chuột vào đây để mở rộng...
A HieuCD ơi
em xin lỗi em làm phiền anh tí xíu ạ,
sau một thời gian chạy em mới hiểu hết được vấn đề phát sinh cần a giúp đỡ thêm.
với code hiện tại đã sắp xếp giống như chức năng sort trong excel rồi nhưng giờ em muốn sắp xếp thêm các điều kiện nữa.
cụ thể như sau
1. khi nhấn nút sắp xếp các ô ở dòng thứ 2 sẽ sắp xếp giống như thứ tự ưu tiên em đang để hiện tại em đánh số từ 1 đến 5 theo chức năng sort
2. các "ITEM CODE" giống nhau ở cột K sẽ được sắp xếp liền nhau theo điều kiện
- Nếu các "ITEM CODE" đó có cùng "MACHINE" ở cột P nhưng khác ngày "FINAL D" ở cột G thì ưu tiên lấy ngày từ bé đến lớn sao cho tổng ở cột T của "ITEM CODE" đó <=5
Vi dụ dòng số 16, 23, 60, 61, 62, 63, 64 có cùng "ITEM CODE" = CB602675B nhưng lại khác ngày ở cột G thì ưu tiên lấy ngày từ bé bắt đầu từ dòng 16 23, 60, 61, 62, đến dòng 63 vì có ở cột T = 1.56 thỏa mãn điều kiện <=5, không lấy dòng 64 vì tổng ở cột T > 5.
- sau khi sắp xếp xong đánh số thứ tự ở cột A bắt đầu từ dòng số 4, điền 1 2 3 4 5... đến hết các dòng có dữ liệu.

3.
Công thức ở cột M và N nó cứ nhảy lung tung ô tham chiếu gây nhẫm lẫn sai số, mỗi lần nhấn nút sắp xếp a viết code giúp em làm sao vẫn giữ được đúng ô tham chiếu với
 

File đính kèm

  • sort.xlsb
    756 KB · Đọc: 5
Lần chỉnh sửa cuối:
Upvote 0
Thuy.Vuong đã viết:
A HieuCD ơi
em xin lỗi em làm phiền anh tí xíu ạ,
sau một thời gian chạy em mới hiểu hết được vấn đề phát sinh cần a giúp đỡ thêm.
với code hiện tại đã sắp xếp giống như chức năng sort trong excel rồi nhưng giờ em muốn sắp xếp thêm các điều kiện nữa.
cụ thể như sau
1. khi nhấn nút sắp xếp các ô ở dòng thứ 2 sẽ sắp xếp giống như thứ tự ưu tiên em đang để hiện tại em đánh số từ 1 đến 5 theo chức năng sort
2. các "ITEM CODE" giống nhau ở cột K sẽ được sắp xếp liền nhau theo điều kiện
- Nếu các "ITEM CODE" đó có cùng "MACHINE" ở cột P nhưng khác ngày "FINAL D" ở cột G thì ưu tiên lấy ngày từ bé đến lớn sao cho tổng ở cột T của "ITEM CODE" đó <=5
Vi dụ dòng số 16, 23, 60, 61, 62, 63, 64 có cùng "ITEM CODE" = CB602675B nhưng lại khác ngày ở cột G thì ưu tiên lấy ngày từ bé bắt đầu từ dòng 16 23, 60, 61, 62, đến dòng 63 vì có ở cột T = 1.56 thỏa mãn điều kiện <=5, không lấy dòng 64 vì tổng ở cột T > 5.
- sau khi sắp xếp xong đánh số thứ tự ở cột A bắt đầu từ dòng số 4, điền 1 2 3 4 5... đến hết các dòng có dữ liệu.

3.
Công thức ở cột M và N nó cứ nhảy lung tung ô tham chiếu gây nhẫm lẫn sai số, mỗi lần nhấn nút sắp xếp a viết code giúp em làm sao vẫn giữ được đúng ô tham chiếu với
Nhấp chuột vào đây để mở rộng...
3/ Công thức cột M và N xóa bỏ tên sheet hiện hành: "PFL_PRINT!"
2/ Vụ nầy quá khó vì nhiều thứ còn mập mờ không biết kết quả có hình dáng gì, làm tay thêm kết quả thật chuẩn không được sai sót và gởi lại
 
Upvote 0
HieuCD đã viết:
3/ Công thức cột M và N xóa bỏ tên sheet hiện hành: "PFL_PRINT!"
2/ Vụ nầy quá khó vì nhiều thứ còn mập mờ không biết kết quả có hình dáng gì, làm tay thêm kết quả thật chuẩn không được sai sót và gởi lại
Nhấp chuột vào đây để mở rộng...
Dạ em ngồi nghĩ làm sao để diễn tả cho a hiểu được, em làm thủ công như file đính kèm, cột K được sắp xếp theo như mô tả ở bài 8

Các "ITEM CODE" giống nhau ở cột K sẽ được sắp xếp liền nhau theo điều kiện
- Nếu các "ITEM CODE" đó có cùng "MACHINE" ở cột P nhưng khác ngày "FINAL D" ở cột G thì ưu tiên lấy ngày từ bé đến lớn sao cho tổng ở cột T của "ITEM CODE" đó <=5
Vi dụ dòng số 16, 23, 60, 61, 62, 63, 64 có cùng "ITEM CODE" = CB602675B nhưng lại khác ngày ở cột G thì ưu tiên lấy ngày từ bé bắt đầu từ dòng 16 23, 60, 61, 62, đến dòng 63 vì có ở cột T = 1.56 thỏa mãn điều kiện <=5, không lấy dòng 64 vì tổng ở cột T > 5.

Tương tự như cho các "MATERIAL CODE" giống nhau ở Q ẽ được sắp xếp liền nhau theo điều kiện

- Nếu các "MATERIAL CODE" đó có cùng "MACHINE" ở cột P nhưng khác ngày "FINAL D" ở cột G thì ưu tiên lấy ngày từ bé đến lớn sao cho tổng ở cột T của "MATERIAL CODE" đó <=5

chủ yếu nhất là nếu khác ngày ở cột G thì mới phải tính toán sắp xếp như vậy, còn cùng ngày thì mặc định là sắp xếp liền nhau.
- sau khi sắp xếp xong đánh số thứ tự ở cột A bắt đầu từ dòng số 4, điền 1 2 3 4 5... đến hết các dòng có dữ liệu, thứ tự lặp lại theo "MACHINE" ở cột P

a xem giúp em ạ, nếu em diễn tả khó hiểu quá a cứ code theo các hiểu của a xong rồi sửa tiếp được không ạ.
 

File đính kèm

  • sort.xlsb
    752.5 KB · Đọc: 12
Upvote 0
Thuy.Vuong đã viết:
Dạ em ngồi nghĩ làm sao để diễn tả cho a hiểu được, em làm thủ công như file đính kèm, cột K được sắp xếp theo như mô tả ở bài 8

Các "ITEM CODE" giống nhau ở cột K sẽ được sắp xếp liền nhau theo điều kiện
- Nếu các "ITEM CODE" đó có cùng "MACHINE" ở cột P nhưng khác ngày "FINAL D" ở cột G thì ưu tiên lấy ngày từ bé đến lớn sao cho tổng ở cột T của "ITEM CODE" đó <=5
Vi dụ dòng số 16, 23, 60, 61, 62, 63, 64 có cùng "ITEM CODE" = CB602675B nhưng lại khác ngày ở cột G thì ưu tiên lấy ngày từ bé bắt đầu từ dòng 16 23, 60, 61, 62, đến dòng 63 vì có ở cột T = 1.56 thỏa mãn điều kiện <=5, không lấy dòng 64 vì tổng ở cột T > 5.

Tương tự như cho các "MATERIAL CODE" giống nhau ở Q ẽ được sắp xếp liền nhau theo điều kiện

- Nếu các "MATERIAL CODE" đó có cùng "MACHINE" ở cột P nhưng khác ngày "FINAL D" ở cột G thì ưu tiên lấy ngày từ bé đến lớn sao cho tổng ở cột T của "MATERIAL CODE" đó <=5

chủ yếu nhất là nếu khác ngày ở cột G thì mới phải tính toán sắp xếp như vậy, còn cùng ngày thì mặc định là sắp xếp liền nhau.
- sau khi sắp xếp xong đánh số thứ tự ở cột A bắt đầu từ dòng số 4, điền 1 2 3 4 5... đến hết các dòng có dữ liệu, thứ tự lặp lại theo "MACHINE" ở cột P

a xem giúp em ạ, nếu em diễn tả khó hiểu quá a cứ code theo các hiểu của a xong rồi sửa tiếp được không ạ.
Nhấp chuột vào đây để mở rộng...
Chạy sub XYZ . . .
Mã: 
Option Explicit
Sub XYZ()
  Dim aDK(), arr(), eRow&, sRow&, sCol&, j&, c, ord
 
  Application.ScreenUpdating = False
  With Worksheets("PFL_PRINT")
    eRow = .Range("D" & Rows.Count).End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co du lieu!"): Exit Sub
    sRow = eRow - 3
    aDK = .Range("A2:AF2").Value 'Vung dieu kien sort
    Call dkSort(aDK, arr, sCol)
    If sCol > 0 Then
      .Sort.SortFields.Clear
      For j = 1 To sCol
        If arr(1, j) <> Empty Then
          If arr(2, j) > 0 Then ord = 1 Else ord = 2
          .Sort.SortFields.Add Key:=Range(arr(1, j)).Resize(sRow), _
          SortOn:=xlSortOnValues, Order:=ord, DataOption:=xlSortNormal
        End If
      Next j
      With ActiveWorkbook.Worksheets("PFL_PRINT").Sort
        .SetRange Range("A3:AS" & eRow) 'Sort tu cot A toi cot AS
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
      End With
    End If
  End With
  Call SortItem(sRow)
  Application.ScreenUpdating = True
End Sub

Sub SortItem(sRow)
  Dim sArr(), arr(), dic As Object, iKey$, i&, ik&, tmp#
 
  ReDim arr(1 To sRow, 1 To 2)
  Set dic = CreateObject("scripting.dictionary")
  With Worksheets("PFL_PRINT")
    sArr = .Range("K4:T4").Resize(sRow).Value
    For i = 1 To sRow
      arr(i, 1) = i
      iKey = sArr(i, 1) & "|" & sArr(i, 6)
      If dic.exists(iKey) = False Then
        dic.Add iKey, i
        arr(i, 2) = sArr(i, 10)
      Else
        ik = dic.Item(iKey)
        If arr(ik, 2) < 5 Then
          tmp = arr(ik, 2) + sArr(i, 10)
          If tmp <= 5 Then
            arr(i, 1) = ik
            arr(i, 2) = tmp
          End If
        End If
      End If
    Next i
    .Range("AT4").Resize(sRow).Value = arr
    .Range("A4:AT4").Resize(sRow).Sort .Range("AT4"), 1, Header:=xlNo
    .Range("AT4").Resize(sRow).ClearContents
  End With
End Sub

Private Sub dkSort(aDK, arr, sCol)
  Dim j&, c, cAbs&
  For j = 1 To UBound(aDK, 2)
    c = aDK(1, j)
    If c <> Empty And IsNumeric(c) Then
      cAbs = Abs(c)
      If sCol < cAbs Then
        sCol = cAbs
        ReDim Preserve arr(1 To 2, 1 To sCol)
      End If
      arr(1, cAbs) = Cells(4, j).Address(0, 0)
      arr(2, cAbs) = c
    End If
  Next j
End Sub
 
Upvote 0
HieuCD đã viết:
Chạy sub XYZ . . .
Mã: 
Option Explicit
Sub XYZ()
  Dim aDK(), arr(), eRow&, sRow&, sCol&, j&, c, ord
 
  Application.ScreenUpdating = False
  With Worksheets("PFL_PRINT")
    eRow = .Range("D" & Rows.Count).End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co du lieu!"): Exit Sub
    sRow = eRow - 3
    aDK = .Range("A2:AF2").Value 'Vung dieu kien sort
    Call dkSort(aDK, arr, sCol)
    If sCol > 0 Then
      .Sort.SortFields.Clear
      For j = 1 To sCol
        If arr(1, j) <> Empty Then
          If arr(2, j) > 0 Then ord = 1 Else ord = 2
          .Sort.SortFields.Add Key:=Range(arr(1, j)).Resize(sRow), _
          SortOn:=xlSortOnValues, Order:=ord, DataOption:=xlSortNormal
        End If
      Next j
      With ActiveWorkbook.Worksheets("PFL_PRINT").Sort
        .SetRange Range("A3:AS" & eRow) 'Sort tu cot A toi cot AS
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
      End With
    End If
  End With
  Call SortItem(sRow)
  Application.ScreenUpdating = True
End Sub

Sub SortItem(sRow)
  Dim sArr(), arr(), dic As Object, iKey$, i&, ik&, tmp#
 
  ReDim arr(1 To sRow, 1 To 2)
  Set dic = CreateObject("scripting.dictionary")
  With Worksheets("PFL_PRINT")
    sArr = .Range("K4:T4").Resize(sRow).Value
    For i = 1 To sRow
      arr(i, 1) = i
      iKey = sArr(i, 1) & "|" & sArr(i, 6)
      If dic.exists(iKey) = False Then
        dic.Add iKey, i
        arr(i, 2) = sArr(i, 10)
      Else
        ik = dic.Item(iKey)
        If arr(ik, 2) < 5 Then
          tmp = arr(ik, 2) + sArr(i, 10)
          If tmp <= 5 Then
            arr(i, 1) = ik
            arr(i, 2) = tmp
          End If
        End If
      End If
    Next i
    .Range("AT4").Resize(sRow).Value = arr
    .Range("A4:AT4").Resize(sRow).Sort .Range("AT4"), 1, Header:=xlNo
    .Range("AT4").Resize(sRow).ClearContents
  End With
End Sub

Private Sub dkSort(aDK, arr, sCol)
  Dim j&, c, cAbs&
  For j = 1 To UBound(aDK, 2)
    c = aDK(1, j)
    If c <> Empty And IsNumeric(c) Then
      cAbs = Abs(c)
      If sCol < cAbs Then
        sCol = cAbs
        ReDim Preserve arr(1 To 2, 1 To sCol)
      End If
      arr(1, cAbs) = Cells(4, j).Address(0, 0)
      arr(2, cAbs) = c
    End If
  Next j
End Sub
Nhấp chuột vào đây để mở rộng...
em cám ơn anh nhé, em sẽ kiểm tra kĩ xem nó chạy thế nào ạ
 
Upvote 0
HieuCD đã viết:
Chạy sub XYZ . . .
Mã: 
Option Explicit
Sub XYZ()
  Dim aDK(), arr(), eRow&, sRow&, sCol&, j&, c, ord
 
  Application.ScreenUpdating = False
  With Worksheets("PFL_PRINT")
    eRow = .Range("D" & Rows.Count).End(xlUp).Row
    If eRow < 5 Then MsgBox ("Khong co du lieu!"): Exit Sub
    sRow = eRow - 3
    aDK = .Range("A2:AF2").Value 'Vung dieu kien sort
    Call dkSort(aDK, arr, sCol)
    If sCol > 0 Then
      .Sort.SortFields.Clear
      For j = 1 To sCol
        If arr(1, j) <> Empty Then
          If arr(2, j) > 0 Then ord = 1 Else ord = 2
          .Sort.SortFields.Add Key:=Range(arr(1, j)).Resize(sRow), _
          SortOn:=xlSortOnValues, Order:=ord, DataOption:=xlSortNormal
        End If
      Next j
      With ActiveWorkbook.Worksheets("PFL_PRINT").Sort
        .SetRange Range("A3:AS" & eRow) 'Sort tu cot A toi cot AS
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
      End With
    End If
  End With
  Call SortItem(sRow)
  Application.ScreenUpdating = True
End Sub

Sub SortItem(sRow)
  Dim sArr(), arr(), dic As Object, iKey$, i&, ik&, tmp#
 
  ReDim arr(1 To sRow, 1 To 2)
  Set dic = CreateObject("scripting.dictionary")
  With Worksheets("PFL_PRINT")
    sArr = .Range("K4:T4").Resize(sRow).Value
    For i = 1 To sRow
      arr(i, 1) = i
      iKey = sArr(i, 1) & "|" & sArr(i, 6)
      If dic.exists(iKey) = False Then
        dic.Add iKey, i
        arr(i, 2) = sArr(i, 10)
      Else
        ik = dic.Item(iKey)
        If arr(ik, 2) < 5 Then
          tmp = arr(ik, 2) + sArr(i, 10)
          If tmp <= 5 Then
            arr(i, 1) = ik
            arr(i, 2) = tmp
          End If
        End If
      End If
    Next i
    .Range("AT4").Resize(sRow).Value = arr
    .Range("A4:AT4").Resize(sRow).Sort .Range("AT4"), 1, Header:=xlNo
    .Range("AT4").Resize(sRow).ClearContents
  End With
End Sub

Private Sub dkSort(aDK, arr, sCol)
  Dim j&, c, cAbs&
  For j = 1 To UBound(aDK, 2)
    c = aDK(1, j)
    If c <> Empty And IsNumeric(c) Then
      cAbs = Abs(c)
      If sCol < cAbs Then
        sCol = cAbs
        ReDim Preserve arr(1 To 2, 1 To sCol)
      End If
      arr(1, cAbs) = Cells(4, j).Address(0, 0)
      arr(2, cAbs) = c
    End If
  Next j
End Sub
Nhấp chuột vào đây để mở rộng...
Chưa chắc xyz đã kết thúc.
 
Upvote 0
Thuy.Vuong đã viết:
...
a xem giúp em ạ, nếu em diễn tả khó hiểu quá a cứ code theo các hiểu của a xong rồi sửa tiếp được không ạ.
Nhấp chuột vào đây để mở rộng...
Có lẽ bạn rủ bác viết code ở trên ra đâu đó tra đổi ý tưởng, tiện thể làm mẹt thịt chó & vài xị đế, chắc cuối bữa là ra hết ngay thôi :D:D:D
 
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

ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
8 9 10
Trả lời
193
Đọc
10K
qtm1987
Q
OverAC
Gặp gỡ giao lưu tại Hà Nội, chiều ngày 10/11/2025. cùng Ptm0412, OverAC và các anh chị thân thiết.
    • Thích
    • Yêu thích
Trả lời
4
Đọc
112
viethung78
V
Hai Lúa Miền Tây
Nhập liệu, truy vấn dữ liệu qua Internet = VB.Net
    • Thích
2
Trả lời
26
Đọc
10K
phamduyhoang2907
P
P
Connection string cho SQL Express 2005
Trả lời
7
Đọc
7K
phamduyhoang2907
P
T
Xin trợ giúp code về dò tìm dữ liệu
Trả lời
4
Đọc
168
CHAOQUAY
C
HeSanbi
  • Question
Lỗi VBA: Cài đặt thông số ForceVBALoadFromSource trong Registry để VBA biên dịch không bị lỗi
Trả lời
2
Đọc
84
HeSanbi
HeSanbi
Quyen182
  • Question
Xin giúp code VBA để chèn ảnh có sẵn trong Excel vào phần comment
Trả lời
0
Đọc
57
Quyen182
Quyen182
B
  • Question
Xin hướng dẫn tách 1 vùng dữ liệu sang thành nhiều sheet
Trả lời
2
Đọc
64
Hoàng Tuấn 868
H
Toanke063
  • Question
Xin hỏi code vba chuyển 1 file pdf bất kì thành ảnh
Trả lời
7
Đọc
152
cantl
C
HeSanbi
  • Đã giải quyết
ZaloExcel v2.91: Gửi tin nhắn, hình ảnh, bảng, biểu đồ, tập tin, tạo nhóm, thu thập tin nhắn
    • Thích
    • Cảm ơn
    • Yêu thích
2 3
Trả lời
55
Đọc
13K
HeSanbi
HeSanbi
Bebooby
Tách mã sản phẩm trong chuỗi thông tin
Trả lời
2
Đọc
61
NT Ngoc Yen
N
thlpro
Truy Vấn Công thức từ Sheet này Qua Sheet Khác
Trả lời
8
Đọc
170
thlpro
thlpro
N
  • Question
VBA - copy các sheets unhide và dạng giá trị theo vùng xác định
Trả lời
3
Đọc
108
huhumalu
H
S
Lý do công thức bị mờ tại ô Function
    • Cười
Trả lời
2
Đọc
73
sakurasumo
S
GPE-Trợ Lý
Đăng ký tham dự hội thảo tại Hà Nội: Power Query - Công cụ quản lý dữ liệu
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
5
Đọc
655
GPE-Trợ Lý
GPE-Trợ Lý
N
  • Question
Làm ơn viết giùm mình macro làm tròn giá trị ạ
    • Cười
Trả lời
14
Đọc
139
ptm0412
ptm0412
CNKyNguyen
Giảm dung lượng của file excel
    • Cảm ơn
    • Cười
    • Thích
Trả lời
2
Đọc
247
CNKyNguyen
CNKyNguyen
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
9
Đọc
420
vostro 1500
vostro 1500
P
Sự cố về hàm SUMIF
Trả lời
8
Đọc
240
yeudoi
yeudoi
OverAC
Thông báo nội dung xấu và bài viết vi phạm nội quy.
19 20 21
Trả lời
416
Đọc
41K
vanle33
vanle33
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