sắp xếp dữ liệu sang một sheet khác

[tamhoncuada10313]

Em có một bài toán như sau,mong các bác giải hộ:Có ít nhất là 2 nhóm sản phẩm trở lên,mỗi sản phẩm được đánh mã để khi nhìn vào mã ta biết sản phẩm đó thuộc nhóm nào. Ở sheet 1 ta nhập vào dữ liệu của các sản phẩm thuộc các nhóm nhưng không theo trình tự. Giờ em muốn tạo một nút "sắp xếp" để khi ta ấn vào đó, dữ liệu sẽ chép sang sheet khác và tự động sắp xếp vào theo nhóm

 

[tamhoncuada10313]

Em xin gửi ví dụ mẫu

 

[SA_DQ]

Theo ví dụ mẫu

Macro này sẽ giúp bạn, được chăng?!
Cái hình bạn cho vô sheets("sheet1") đó không mang được macro thì phải
Mình đề nghị lấy hình khác, mang được macro!

Option Explicit
Dim lRow As Long

Sub CopyFor()

 Dim Rng As Range:                  Dim Wz As Long
 Sheets("Sheet1").Select
 lRow = [c65432].End(xlUp).Row:          Xep [C3]
 Sheets("Sheet2").Range("B3:C" & (lRow + 9)).Clear
 Range("C3:C" & lRow).Copy Destination:=Sheets("Sheet2").[b3]
 Range("B3:B" & lRow).Copy Destination:=Sheets("Sheet2").[C3]
 Xep [b3]:
 lRow = Sheets("Sheet2").[c65432].End(xlUp).Row
 For Wz = 4 To lRow
    With Sheets("Sheet2")
        If .Cells(Wz, 2) = .Cells(Wz, 2).Offset(-1) Then
            If Rng Is Nothing Then
                Set Rng = .Cells(Wz, 2)
            Else
                Set Rng = Union(Rng, .Cells(Wz, 2))
            End If
        End If
    End With
 Next Wz
 Rng = ""
 Set Rng = Nothing
End Sub


Sub Xep(Rng As Range)
    Range("B2:C" & lRow).Select
    Selection.Sort Key1:=Rng, Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
End Sub

 

[tamhoncuada10313]

Bác Sa ơi!em muốn khi lọc sang sheet2 thì dữ liệu sheét ko bị xáo trộn. Làm như bác, dữ liệu sheet1 vẫn bị xáo trộn

 

[SA_DQ]

Nếu vậy phải thêm công đoạn nữa, đó là

Bác Sa ơi!em muốn khi lọc sang sheet2 thì dữ liệu sheet1 ko bị xáo trộn. Làm như bác, dữ liệu sheet1 vẫn bị xáo trộn

Đầu tiên ta chọn cột 'B' của Sheets("sheet1") thêm từ menu insert & gán số thứ tự cho trường mới tạo này (Điều này có thể bạn tự viết thêm vài ba dòng lệnh vô macro chính; hay bạn dùng bộ thu macro & xem nội dung của nó & chép các dòng lệnh thích hợp vô macro đang đề cập. Nếu chưa được thì mình sẽ giúp tiếp!)

Ở macro sau ta sửa dòng lệnh Range("B2:C" & lRow).Select thành:

 Range("A2:C" & lRow).Select

Cuối cùng là dòng lệnh xóa cột tạm!

Chúc vui vẽ!

 

[tamhoncuada10313]

HIX,sao em làm như bác bảo mà vẫn không được hả bác Sa

 

[SA_DQ]

HIX,sao em làm như bác bảo mà vẫn không được hả bác Sa

Cột 'A' của bạn đang còn trống, mình mược tạm nó trong giây lát, nha;
Chú í khi sử dụng:
*/ Các câu lệnh giữa dòng 1..7 là mới thêm;
*/ Các dòng lệnh có số >7 là đã chỉnh sửa;
+++: Chúc vui với thành công mới!

 Option Explicit
Dim lRow As Long

Sub CopyFor()

 Dim Rng As Range:                  Dim Wz As Long
 Sheets("Sheet1").Select:           lRow = [c65432].End(xlUp).Row
1
 [A2].Select:                       ActiveCell.FormulaR1C1 = "TT"
 [A3].Select:                       ActiveCell.FormulaR1C1 = "1"
 [A4].Select:                       ActiveCell.FormulaR1C1 = "2"
 Range("A3:A4").Select
 Selection.AutoFill Destination:=Range("A3:A" & lRow), Type:=xlFillDefault
 Xep [C3]
7
 Sheets("Sheet2").Range("B3:C" & (lRow + 9)).Clear
 Range("C3:C" & lRow).Copy Destination:=Sheets("Sheet2").[b3]
 Range("B3:B" & lRow).Copy Destination:=Sheets("Sheet2").[C3]
9 Xep [A3]:                          Columns(1).Clear
 lRow = Sheets("Sheet2").[c65432].End(xlUp).Row
 For Wz = 4 To lRow
    With Sheets("Sheet2")
        If .Cells(Wz, 2) = .Cells(Wz, 2).Offset(-1) Then
            If Rng Is Nothing Then
                Set Rng = .Cells(Wz, 2)
            Else
                Set Rng = Union(Rng, .Cells(Wz, 2))
            End If
        End If
    End With
 Next Wz
 Rng = ""
 Set Rng = Nothing
End Sub

[B]Sub Xep(Rng As Range)[/B]
21    Range("A2:C" & lRow).Select
    Selection.Sort Key1:=Rng, Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
[B]End Sub[/B]