Sort cột theo điều kiện, bỏ qua ô trống bằng VBA (1 người xem)

[ThaiDieuAnh]

Xin chào các anh chị em trên Giaiphapexcel.com!
Em có 1 File cần Sort theo ngày tháng nhưng khi vì trong vùng chọn có ô trống nên khi sort các ô trống bị dồn lên trên hoặc dồn xuông dưới. Do đó em phải đặt thêm cột phụ kết hợp Filter để chọn từng nhóm rồi Sort. Tuy nhiên nếu nhiều nhóm thì rất mất thời gian, các anh chị có thể nghĩ và viết code dùm em để khi chỉ cần chạy VBA thì nó sẽ Sort ngày tháng như yêu cầu trong File đính kèm dưới đây không ạ?

 

[quanluu]

Xin chào các anh chị em trên Giaiphapexcel.com!
Em có 1 File cần Sort theo ngày tháng nhưng khi vì trong vùng chọn có ô trống nên khi sort các ô trống bị dồn lên trên hoặc dồn xuông dưới. Do đó em phải đặt thêm cột phụ kết hợp Filter để chọn từng nhóm rồi Sort. Tuy nhiên nếu nhiều nhóm thì rất mất thời gian, các anh chị có thể nghĩ và viết code dùm em để khi chỉ cần chạy VBA thì nó sẽ Sort ngày tháng như yêu cầu trong File đính kèm dưới đây không ạ?

Bạn thử code này xem sao

Sub test()
Dim i As Integer, lr As Integer
    Range("E3").Value = "Sort"
    lr = Range("C65000").End(3).Row
    For i = 4 To lr
        Cells(i, 5) = Cells(i - 1, 5)
        If Cells(i, 4) = "" Then
            Cells(i, 4) = 0
            Cells(i, 5) = Cells(i, 3)
        End If
    Next
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("E4:E" & lr) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("D4:D" & lr) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A3:E" & lr)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    For i = 4 To lr
        If Cells(i, 4) = 0 Then Cells(i, 4) = ""
    Next
    Range("E3:E" & lr).Clear
End Sub

 

[giaiphap]

Bạn cũng có thể sử dụng code này thử xem.

Sub Sort()
On Error Resume Next
Dim i As Long
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
For i = Range("B65000").End(xlUp).Row To 4 Step -1
    If Cells(i, 2).Value = "N" Then
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Range(Cells(i, 2).Offset(1, 2), Cells(i, 2).Offset(1, 2).End(xlDown)).Address) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range(Range(Cells(i, 2).Offset(1, 1), Cells(i, 2).Offset(1, 2).End(xlDown)).Address)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    End If
Next i
End Sub

 

[Let'GâuGâu]

Xin chào các anh chị em trên Giaiphapexcel.com!
Em có 1 File cần Sort theo ngày tháng nhưng khi vì trong vùng chọn có ô trống nên khi sort các ô trống bị dồn lên trên hoặc dồn xuông dưới. Do đó em phải đặt thêm cột phụ kết hợp Filter để chọn từng nhóm rồi Sort. Tuy nhiên nếu nhiều nhóm thì rất mất thời gian, các anh chị có thể nghĩ và viết code dùm em để khi chỉ cần chạy VBA thì nó sẽ Sort ngày tháng như yêu cầu trong File đính kèm dưới đây không ạ?

góp vui văn nghệ văn gừng
=====
xóa dòng 28-29-30 đi nha

Option Explicit

Sub Sort_theonhom()
Dim Sarr, temp, arr(1 To 60000, 1 To 4), tam, itm
Dim i, k, j As Long
Dim st As String

On Error GoTo thoat
Sarr = Range([A4], [a60000].End(3).Offset(1)).Resize(, 4).Value2

For i = 1 To UBound(Sarr)
    If Sarr(i, 1) = "" Then
        If IsArray(temp) Then
            k = k + 1
            arr(k, 2) = "N": arr(k, 3) = Sarr(k, 3)
        
            st = Trim(Join(temp, ""))
            tam = Split(st, " ")
            For Each itm In tam
                k = k + 1
                For j = 1 To 4
                    arr(k, j) = Sarr(Val(itm), j)
                Next
            Next
        End If
        ReDim temp(1 To 50000)
    Else
        If temp(Sarr(i, 4)) = "" Then
            temp(Sarr(i, 4)) = i & " "
        Else
            temp(Sarr(i, 4)) = temp(Sarr(i, 4)) & i & " "
        End If
            
    End If
Next
[G4].Resize(i, 4).Value = arr
thoat:
If Err Then MsgBox Err.Description

End Sub

 

[ThaiDieuAnh]

Bác quanluu giúp em sửa code khi nhập liệu cột D chưa đúng (ngày tháng chưa đủ hoặc chưa đúng quy cách) thì có box Thông báo "thiếu dữ liệu" đồng thời không chạy code. Vì code bác chạy đúng nếu nhập dữ liệu đúng, nếu cột D thiếu ngày là nhảy tùm lum à.
Code bác Let' Go cũng hay nhưng em đọc nỏ hiểu. Bác lại chơi dữ liệu đường này xuất ra đường kia làm em kéo về không được

 

[ThaiDieuAnh]

Em sửa được theo ý mình rồi, cảm ơn tất cả mọi người ạ

 

[ndu96081631]

Mọi chuyện cũng đã xong nhưng cũng góp vui:

Sub GroupSort()
  Dim rng As Range, rngArea As Range
  On Error Resume Next
  With Sheet1
    Set rng = .Range("A5", .Range("A60000").End(xlUp)).SpecialCells(xlCellTypeConstants, 1)
  End With
  On Error GoTo 0
  If Not rng Is Nothing Then
    For Each rngArea In rng.Areas
      rngArea.Resize(, 4).Sort rngArea(1, 4), xlAscending, Header:=xlNo
    Next
  End If
End Sub

 

[ThaiDieuAnh]

Mọi chuyện cũng đã xong nhưng cũng góp vui:

Sub GroupSort()
  Dim rng As Range, rngArea As Range
  On Error Resume Next
  With Sheet1
    Set rng = .Range("A5", .Range("A60000").End(xlUp)).SpecialCells(xlCellTypeConstants, 1)
  End With
  On Error GoTo 0
  If Not rng Is Nothing Then
    For Each rngArea In rng.Areas
      rngArea.Resize(, 4).Sort rngArea(1, 4), xlAscending, Header:=xlNo
    Next
  End If
End Sub

Chà, cái code của thầy ndu hay quá, nhạc gì cũng nhảy, thiếu ngày tháng nó cũng chơi. Nhờ thầy sửa dùm em tý xíu là giả sử nhập thiếu ngày tháng ở cột D thì nhóm nào thiếu nhóm đó giữ nguyên và tô màu ô thiếu. Còn các nhóm khác vẫn nhảy tưng bừng được không thầy?

 

[ndu96081631]

Chà, cái code của thầy ndu hay quá, nhạc gì cũng nhảy, thiếu ngày tháng nó cũng chơi. Nhờ thầy sửa dùm em tý xíu là giả sử nhập thiếu ngày tháng ở cột D thì nhóm nào thiếu nhóm đó giữ nguyên và tô màu ô thiếu. Còn các nhóm khác vẫn nhảy tưng bừng được không thầy?

Thì vầy thôi:

Sub GroupSort()
  Dim rng As Range, rngArea As Range[COLOR=#ff0000], rngBlank As Range[/COLOR]
  On Error Resume Next
  With Sheet1
    Set rng = .Range("A5", .Range("A60000").End(xlUp)).SpecialCells(xlCellTypeConstants, 1)
  End With
  On Error GoTo 0
  If Not rng Is Nothing Then
    For Each rngArea In rng.Areas
      [COLOR=#ff0000]Set rngBlank = Nothing[/COLOR]
      [COLOR=#ff0000]On Error Resume Next
      Set rngBlank = rngArea.Offset(, 3).SpecialCells(xlCellTypeBlanks)
      On Error GoTo 0[/COLOR]
      [COLOR=#ff0000]If Not rngBlank Is Nothing Then
        rngBlank.Interior.ColorIndex = 6
      Else
        [/COLOR]rngArea.Resize(, 4).Sort rngArea(1, 4), xlAscending, Header:=xlNo[COLOR=#ff0000]
      End If[/COLOR]
    Next
  End If
End Sub

Code tô màu đỏ là những chỗ sửa lại
-------------------------------------
Code trên vẫn còn tiềm ẩn một.. nguy cơ... nhưng thôi, giờ không nói ra đâu, đợi khi nào tình cờ bạn phát hiện ra thì tính tiếp, vậy bạn sẽ nhớ rất dai còn hơn là viết quá đầy đủ khiến bạn rối mắt. Hơn nữa cái nguy cơ mà tôi nói cũng dạng hiếm

 

[ThaiDieuAnh]

Code trên vẫn còn tiềm ẩn một.. nguy cơ... nhưng thôi, giờ không nói ra đâu, đợi khi nào tình cờ bạn phát hiện ra thì tính tiếp, vậy bạn sẽ nhớ rất dai còn hơn là viết quá đầy đủ khiến bạn rối mắt. Hơn nữa cái nguy cơ mà tôi nói cũng dạng hiếm

Code của thầy thì khó sai được rồi, nhưng thầy nói đến "tiềm ẩn một ... nguy cơ ..." thì em phải test đi test lại. Không biết có phải lỗi này không ạ

 

[ndu96081631]

Code của thầy thì khó sai được rồi, nhưng thầy nói đến "tiềm ẩn một ... nguy cơ ..." thì em phải test đi test lại. Không biết có phải lỗi này không ạ

Chính xác là vậy! Cái thằng SpecialCells(xlCellTypeBlanks) cũng kỳ cục lắm, khi chỉ có 1 cell thì nó "tài lanh" liên kết với tất cả những thằng Blanks quanh nó để "nổi loạn"
Bởi vậy, muốn chắc ăn bạn phải bẫy thêm trường hợp NHÓM CHỈ CÓ 1 DÒNG
Bẫy lỗi luôn là việc cực nhọc. Trường hợp này tôi "nằm lòng" nhưng không vội viết ra, cố ý để bạn tự phát hiện sẽ hay hơn