Giúp đỡ sắp xếp lại dữ liệu theo cột ngày tháng năm bằng vba

Chia sẻ bởi:hands

★★★★★

‹ Hàm TỰ ĐỘNG SẮP XẾP THỨ TỰ Xin giúp công thức ghép chuỗi ›

Quảng cáo

Xin chào toàn thể ac trong Diễn đàn GPE
Mình có bảng dữ liệu như như sau:
Cột A5 là thứ tự, B5 là cột ngày tháng năm, C5 là tên nv, D5 Ghi chú ( tiêu đề nhãn, dữ liệu bắt đầu hàng thứ 6 trở đi);
Riêng cột B có dữ liệu ngày tháng năm bị xếp theo lộn xộn. Giờ mình muốn sắp xếp lại dữ liệu theo thứ tự ngày tháng tăng dần sang cột H trở đi (cùng sheet). Tức là bảng dữ liệu A5 -> D5 vẫn giữ nguyên. Bảng dữ liệu từ cột H trở đi thì được sắp xếp lại.
Mình rất mong được các anh chị giúp đỡ.
Mình xin trân thành cảm ơn ạ

Vậy ở cột H dùng hàm small(cột B,row(a1)) rồi kéo xuống được không bạn. Các cột còn lại dùng match với index.
Tạo cột số thứ tự (STT) sau đó sort theo cột ngày, copy dữ liệu sang cột H xong rồi lại sort lại theo cột STT là xong.
Nếu dùng code thì cũng record macro như thế xem thế nào.

Do file excel của mình đã khoá Protect Sheet nên không Sort được nữa, mặt khác nếu Sort thì công thức ở sheet khác sẽ bị lỗi tham chiếu

Thì trước khi sort bạn Unprotect và vụ sort dữ liệu sheet khác lỗi thế nào thì phải có file (có thể là giả định) để mọi người còn giúp chứ?!

Bảng dữ liệu mình cả ngàn dòng nếu đặt công thức vậy sẽ làm file nặng và bị lag, hơn nữa bảng dữ liệu liệu gốc còn nhập hàng ngày nữa. Nếu đặt công thức sẽ rất bất tiện

Bạn nên có file giả định để mọi người có thể code và test thử.
Trong khi chờ các giải pháp khác và Nếu không chê thì có thể dùng tạm code sau:

Option Explicit

Sub Xep()
Dim i&, j&, R&, Lr&, C&, d&
Dim Arr(), KQ()
Dim Rng As Range
Dim Sh As Worksheet
Set Sh = Sheet1
On Error resume next
Lr = Sh.Cells(Rows.Count, "A").End(xlUp).Row
If Lr<=5 then exit sub
Set Rng = Sh.Range("B6:B" & Lr)
Arr = Sh.Range("A6:D" & Lr).Value
R = UBound(Arr): C = UBound(Arr, 2)
ReDim KQ(1 To R, 1 To C)
For i = 1 To R
    For d = 1 To R
        If Arr(d, 2) = Application.Small(Rng, i) Then
            For j = 1 To C
                KQ(i, j) = Arr(d, j)
            Next j
        End If
    Next d
Next i
Sh.Range("H6").Resize(R, C).ClearContents
Sh.Range("H6").Resize(R, C) = KQ
msgbox "Done"
End Sub

Các vẫn đề về bẫy lỗi bạn tự làm.
Chúc thành công.

Code VBA của bạn đã đúng với ý tưởng của mình rồi. Mình cảm ơn bạn rất nhiều…

www.giaiphapexcel.com/diendan/threads/gi%C3%BAp-%C4%91%E1%BB%A1-s%E1%BA%AFp-x%E1%BA%BFp-l%E1%BA%A1i-d%E1%BB%AF-li%E1%BB%87u-theo-c%E1%BB%99t-ng%C3%A0y-th%C3%A1ng-n%C4%83m-b%E1%BA%B1ng-vba.163922/#post-1093896

Khóa học SprinGO phù hợp

Khóa học Power PI – Ứng dung trong Nhân sự

TỔNG QUAN KHÓA HỌC: POWER BI CHO NGÀNH NHÂN SỰ Khóa học Power BI cho Nhân sự được thiết kế dành riêng cho các...

Xem khóa học

★★★★★ 5 ★ 1 👤 1 ▥ 0

‹ Hàm TỰ ĐỘNG SẮP XẾP THỨ TỰ Xin giúp công thức ghép chuỗi ›

Quảng cáo

Bạn nên đọc

One Response

hands says:

03/02/2023 at 2:22 pm

Em chưa thử, nhưng hình như dư 1 vòng lặp i(d) bác hả?!

Cảm ơn bạn đã xem bài.
Vòng for i=1 to R là vòng để lấy giá trị cho hàm Small(Rng,i)
Vòng For d= 1 to R là vòng lặp duyệt từng dong của mảng để lấy dòng thỏa mãn Arr(d,2)=Small(Rng,i).
Thực ra tôi cũng không test kỹ, nếu thừa bạn đính chính lại hộ nhé.
Em thử sửa thế này, bác xem được không nhé!
@chủ thớt test với dữ liệu thật dùm nhé!
```
Option Explicit

Sub Xep()
Dim i&, j&, R&, Lr&, C&, d&
Dim Arr(), KQ()
Dim Rng As Range
Dim Sh As Worksheet
Set Sh = Sheet1
On Error Resume Next
Lr = Sh.Cells(Rows.Count, "A").End(xlUp).Row
If Lr <= 5 Then Exit Sub
Set Rng = Sh.Range("B6:B" & Lr)
Arr = Sh.Range("A6:D" & Lr).Value
R = UBound(Arr): C = UBound(Arr, 2)
ReDim KQ(1 To R, 1 To C)
'For i = 1 To R
    For d = 1 To R
        If Arr(d, 2) = Application.Small(Rng, d) Then
            For j = 1 To C
                KQ(d, j) = Arr(d, j)
            Next j
        End If
    Next d
'Next i
Sh.Range("M6").Resize(R, C).ClearContents
Sh.Range("M6").Resize(R, C) = KQ
MsgBox "Done"
End Sub
```
Cảm ơn bạn, Code của bạn sửa khi lấy dữ liệu bị sai nhiều lắm
Tôi nghĩ để đơn giản thì dùng vba chép dữ liệu sang 1 sheet nào đó không protect để sort rồi chép lại vào cột H của sheet nguồn.
Nó dạng thế này hả bác?!
```
Option Explicit
Sub GPE()
    Dim lr&, Ws As Worksheet
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    For Each Ws In Worksheets
        If Ws.Name = "TEMP" Then Ws.Delete
    Next Ws
    Worksheets.Add after:=Sheets(Sheets.Count)
    ActiveSheet.Name = "TEMP"
    Sheets("HD").Range("A5").CurrentRegion.Copy _
    Sheets("TEMP").Range("A5")
    With Sheets("TEMP")
        lr = .Range("B" & Rows.Count).End(xlUp).Row
        With Range("A5:D" & lr)
            .Sort .Cells(6, 2), 1, Header:=xlGuess
            Sheets("HD").Range("H6:K" & lr).ClearContents
            Sheets("TEMP").Range("B6:D" & lr).Copy Sheets("HD").Range("I6")
        End With
        Sheets("TEMP").Delete
    End With
    With Sheets("HD")
        .Range("A6:A" & lr).Copy .Range("H6")
    End With
    MsgBox "Done"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
```
Chắc là như vậy đó. Test vài dòng chạy ổn là tốt rồi. Dùng sort của Excel cho đỡ viết code sort lằng nhằng mà chưa chắc đã ổn.

File giả định tôi tự lập trên máy tôi chạy tốt mà.
Có mỗi yêu cầu gửi file giả định lên mà cũng không đáp ứng được, thử hỏi bạn chủ thớt muốn được ăn sẵn mà không cần nhọc công sao? Tôi cũng không hiểu sao các thành viên khác cứ phải tốn thời gian và công sức nhỉ?2992

Đầu năm nên mọi người còn vui vẻ dễ tính đấy thôi. Vài hôm nữa là đâu lại vào đấy à. –=0

Mình đã gửi file giả định ở trên rồi mà bạn. Ngay từ đầu mình quên không gửi file nên mong bạn thông cảm. Vấn đề trên nhờ các bạn giúp đỡ mình đã xử lý được rồi ạ

Reply