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

Liên hệ QC
C

chidung2009

Thành viên hoạt động
Tham gia
12/9/12
Bài viết
123
Được thích
8
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 ạ
 
chidung2009 đã viết:
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 ạ
Nhấp chuột vào đây để mở rộng...
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.
 
THÓC SAMA đã viết:
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.
Nhấp chuột vào đây để mở rộng...
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
 
chidung2009 đã viết:
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
Nhấp chuột vào đây để mở rộng...
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ứ?!
 
chidung2009 đã viết:
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 ạ
Nhấp chuột vào đây để mở rộng...
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.
 
LmoovoenX đã viết:
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.
Nhấp chuột vào đây để mở rộng...
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
 
chidung2009 đã viết:
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 ạ
Nhấp chuột vào đây để mở rộng...
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:
Mã: 
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.
 
HUONGHCKT đã viết:
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:
Mã: 
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.
Nhấp chuột vào đây để mở rộ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...
 
HUONGHCKT đã viết:
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:
Mã: 
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.
Nhấp chuột vào đây để mở rộng...
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é.
 
HUONGHCKT đã viết:
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é.
Nhấp chuột vào đây để mở rộng...
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é!
Mã: 
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
 
HUONGHCKT đã viết:
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:
Mã: 
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.
Nhấp chuột vào đây để mở rộng...
Sau khi mình kiểm tra lại thì dữ liệu chuyển sang bảng mới bị sai, nhất là khi có nhiều hàng cùng ngày thì code lấy dữ liệu bị sai
Bài đã được tự động gộp:

THÓC SAMA đã viết:
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é!
Mã: 
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
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn, Code của bạn sửa khi lấy dữ liệu bị sai nhiều lắm
 

File đính kèm

  • GPE.xlsm
    273.6 KB · Đọc: 8
  • hinh.jpg
    hinh.jpg
    139.8 KB · Đọc: 15
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.
 
Maika8008 đã viết:
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.
Nhấp chuột vào đây để mở rộng...
Nó dạng thế này hả bác?!
Mã: 
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
 
THÓC SAMA đã viết:
Nó dạng thế này hả bác?!
Mã: 
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
Nhấp chuột vào đây để mở rộng...
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ỉ?
 

File đính kèm

  • Screenshot (83).png
    Screenshot (83).png
    302.9 KB · Đọc: 10
Lần chỉnh sửa cuối:
HUONGHCKT đã viết:
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ỉ?
Nhấp chuột vào đây để mở rộng...
Đầ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
 
HUONGHCKT đã viết:
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ỉ?
Nhấp chuột vào đây để mở rộng...
Đầu năm nên xuề xoà tí cho vui bác!
 
HUONGHCKT đã viết:
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ỉ?
Nhấp chuột vào đây để mở rộng...
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 ạ
 
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

LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2
Trả lời
37
Đọc
506
huhumalu
H
S
Slicer không chuyển qua trạng thái mờ.
Trả lời
2
Đọc
46
SteveNguyen1991
S
H
Kết nối vba với Database host (hiện tại đang làm host web)
Trả lời
2
Đọc
120
Haidang7979
H
emlat3
Đặt màu xen kẽ các dòng theo ký tự
Trả lời
1
Đọc
43
DeTong
D
S
  • Question
Không lấy đủ dữ liệu bằng kết nối ADO
2
Trả lời
20
Đọc
357
shnhatha221108
S
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