Code VBA Sort từng dòng và sao chép lại

[chaukimsa]

Xin chào mọi người !

Mình thực hành VBA Sort từng cột ở sheet1 rồi copy qua sheet 2 , ở bài này mình Sort từ cột phải sang trái , sort cột nào thì copy cột bên trái cột đó.

Mình đang làm thủ công nên nhiều lắm hãy giúp mình code VBA cho dể dàng , xin cám ơn !

 

[Trần Tuấn Anh 3108]

Xin chào,
Bạn có khoảng trên 100 cột cần sort lần lượt và nếu làm theo hướng hiện tại thì sẽ tốn cỡ 200 dòng code để hoàn tất.
Hãy dùng vòng lặp For để giảm công sức coding. Để làm được điều đó hãy thay đổi cách duyệt range.
Cụ thể: Thay vì viết Sheet1.Range("A10") sẽ viết thành Sheet1.Cells(i,j) (với i là hàng, j là cột). Sẽ dùng lệnh For để duyệt các cột qua biến j.

 

[Nhattanktnn]

Xin chào mọi người !

Mình thực hành VBA Sort từng cột ở sheet1 rồi copy qua sheet 2 , ở bài này mình Sort từ cột phải sang trái , sort cột nào thì copy cột bên trái cột đó.

Mình đang làm thủ công nên nhiều lắm hãy giúp mình code VBA cho dể dàng , xin cám ơn !

5 cột này sẽ gán xuống sheet2 trong lần sort bao nhiêu?


Cột F:CZ số liệu chỉ là 0 và 1, vậy nên chăng không cần sort mà chỉ cần đếm có bao nhiêu số 1 (hoặc 0 ) trong cột đó rồi điền 1 từ trên xuống, hết 1 thì điền 0?

 

[chaukimsa]

5 cột này sẽ gán xuống sheet2 trong lần sort bao nhiêu?
View attachment 259368

Cột F:CZ số liệu chỉ là 0 và 1, vậy nên chăng không cần sort mà chỉ cần đếm có bao nhiêu số 1 (hoặc 0 ) trong cột đó rồi điền 1 từ trên xuống, hết 1 thì điền 0?

Xin chào ! ở sheet2 cần copy dữ liệu sort của sheet1 sẽ có giá trị Sum (tổng hàng ngang) và Macht +(số 1 nối liên tiếp),Macht -(số 0 nối liên tiếp) hoàn toàn khác ạ .

 

[CHAOQUAY]

Sort rồi dán tất cả các cột hay chỉ là 1 số lượng cho trước

Xin chào mọi người !

Mình thực hành VBA Sort từng cột ở sheet1 rồi copy qua sheet 2 , ở bài này mình Sort từ cột phải sang trái , sort cột nào thì copy cột bên trái cột đó.

Mình đang làm thủ công nên nhiều lắm hãy giúp mình code VBA cho dể dàng , xin cám ơn !

 

[chaukimsa]

Sort rồi dán tất cả các cột hay chỉ là 1 số lượng cho trước

Thân chào !Mình đang cần sao chép sort từ cột cz về cột F của sheet1 về sheet2 ạ .Mình làm thủ công mới được được vài cột thôi .hihihihiihih

 

[CHAOQUAY]

Thân chào !Mình đang cần sao chép sort từ cột cz về cột F của sheet1 về sheet2 ạ .Mình làm thủ công mới được được vài cột thôi .hihihihiihih

Thử code dưới đây, số lượng cột có thể điều chỉnh nếu cần

Option Explicit

Sub sort_()
Dim Nguon, slD, slC
Dim Tieude
Dim Csd
Dim Kq
Dim i, j, k, x, z, t

Nguon = Sheet1.Range("A10").CurrentRegion
Tieude = Sheet1.Range("A7").CurrentRegion
slD = UBound(Nguon)
slC = UBound(Nguon, 2)
ReDim Csd(1 To slD, 1 To 1), Kq(1 To slD, 1 To 1)

With Sheet2
    .UsedRange.Clear
    .Range("A7").Resize(1, slC) = Tieude
    
    For i = 1 To slD
        Csd(i, 1) = i
    Next i
    
    For j = slC To slC - 99 + 1 Step -1
        k = 0
        For i = 1 To slD
            x = Csd(i, 1)
            If Nguon(x, j) = 1 Then
                k = k + 1
                t = Csd(k, 1)
                Csd(k, 1) = Csd(i, 1)
                Csd(i, 1) = t
            End If
        Next i
        For i = 1 To slD
            x = Csd(i, 1)
            Kq(i, 1) = Nguon(x, j - 1)
        Next i
        
        .Range("A10").Offset(, j - 1).Resize(slD, 1) = Kq
    Next j
    
    .UsedRange.Columns.AutoFit
End With
End Sub

 

[Hai Lúa Miền Tây]

sort cột nào thì copy cột bên trái cột đó.

Có nghĩa là sao bạn?

 

[chaukimsa]

Có nghĩa là sao bạn?

Mến chào ạ !
ở trong bảng dử liệu này thì khi sort hàng dọc nào thì phía bên trái là hàng dọc sát bên là so sách 1 hay 0 và mình sao chép hàng bên trái hàng sort qua sheet2 ạ .

Bài đã được tự động gộp: 25/5/21

Thử code dưới đây, số lượng cột có thể điều chỉnh nếu cần

Option Explicit

Sub sort_()
Dim Nguon, slD, slC
Dim Tieude
Dim Csd
Dim Kq
Dim i, j, k, x, z, t

Nguon = Sheet1.Range("A10").CurrentRegion
Tieude = Sheet1.Range("A7").CurrentRegion
slD = UBound(Nguon)
slC = UBound(Nguon, 2)
ReDim Csd(1 To slD, 1 To 1), Kq(1 To slD, 1 To 1)

With Sheet2
    .UsedRange.Clear
    .Range("A7").Resize(1, slC) = Tieude
   
    For i = 1 To slD
        Csd(i, 1) = i
    Next i
   
    For j = slC To slC - 99 + 1 Step -1
        k = 0
        For i = 1 To slD
            x = Csd(i, 1)
            If Nguon(x, j) = 1 Then
                k = k + 1
                t = Csd(k, 1)
                Csd(k, 1) = Csd(i, 1)
                Csd(i, 1) = t
            End If
        Next i
        For i = 1 To slD
            x = Csd(i, 1)
            Kq(i, 1) = Nguon(x, j - 1)
        Next i
       
        .Range("A10").Offset(, j - 1).Resize(slD, 1) = Kq
    Next j
   
    .UsedRange.Columns.AutoFit
End With
End Sub

cám ơn thật nhiều em đang tìm hiểu ...code chạy rất nhanh !

 

[VetMini]

Có nghĩa là sao bạn?

Có nghĩa là câu hỏi thuộc loại xổ số. Mời mọc mọi người thử. Một hoặc vài người sẽ trúng. Nếu không có ai trúng thì nhỉ thêm vài giọt, xổ số lại.

 

[chaukimsa]

Có nghĩa là câu hỏi thuộc loại xổ số. Mời mọc mọi người thử. Một hoặc vài người sẽ trúng. Nếu không có ai trúng thì nhỉ thêm vài giọt, xổ số lại.

Người tài đầy lòng nhân ái ......!

 

[chaukimsa]

Thử code dưới đây, số lượng cột có thể điều chỉnh nếu cần

Option Explicit

Sub sort_()
Dim Nguon, slD, slC
Dim Tieude
Dim Csd
Dim Kq
Dim i, j, k, x, z, t

Nguon = Sheet1.Range("A10").CurrentRegion
Tieude = Sheet1.Range("A7").CurrentRegion
slD = UBound(Nguon)
slC = UBound(Nguon, 2)
ReDim Csd(1 To slD, 1 To 1), Kq(1 To slD, 1 To 1)

With Sheet2
    .UsedRange.Clear
    .Range("A7").Resize(1, slC) = Tieude
   
    For i = 1 To slD
        Csd(i, 1) = i
    Next i
   
    For j = slC To slC - 99 + 1 Step -1
        k = 0
        For i = 1 To slD
            x = Csd(i, 1)
            If Nguon(x, j) = 1 Then
                k = k + 1
                t = Csd(k, 1)
                Csd(k, 1) = Csd(i, 1)
                Csd(i, 1) = t
            End If
        Next i
        For i = 1 To slD
            x = Csd(i, 1)
            Kq(i, 1) = Nguon(x, j - 1)
        Next i
       
        .Range("A10").Offset(, j - 1).Resize(slD, 1) = Kq
    Next j
   
    .UsedRange.Columns.AutoFit
End With
End Sub

Cảm ơn anh rất nhiêu ,code này sử dụng tốt cho sort xlDescending,còn sử dụng cho sort xlAscending thì cần viết code lại lại chổ nào vậy anh ?

 

[CHAOQUAY]

Cảm ơn anh rất nhiêu ,code này sử dụng tốt cho sort xlDescending,còn sử dụng cho sort xlAscending thì cần viết code lại lại chổ nào vậy anh ?

Thay dòng If ... = 1 -> thành dòng If... = 0 rồi chạy thử

            'If Nguon(x, j) = 1 Then
            If Nguon(x, j) = 0 Then
                k = k + 1
                t = Csd(k, 1)
                Csd(k, 1) = Csd(i, 1)
                Csd(i, 1) = t
            End If

 

[Maika8008]

Xin chào mọi người !

Mình thực hành VBA Sort từng cột ở sheet1 rồi copy qua sheet 2 , ở bài này mình Sort từ cột phải sang trái , sort cột nào thì copy cột bên trái cột đó.

Mình đang làm thủ công nên nhiều lắm hãy giúp mình code VBA cho dể dàng , xin cám ơn !

Chán nhỉ!? Người ta theo chiều thuận, còn mình cứ thích nghịch thôi mà: "mình Sort từ cột phải sang trái , sort cột nào thì copy cột bên trái cột đó."

 

[chaukimsa]

Thay dòng If ... = 1 -> thành dòng If... = 0 rồi chạy thử

            'If Nguon(x, j) = 1 Then
            If Nguon(x, j) = 0 Then
                k = k + 1
                t = Csd(k, 1)
                Csd(k, 1) = Csd(i, 1)
                Csd(i, 1) = t
            End If

Cám ơn anh nhiều lắm ,code chạy rất nhanh và mình áp dụng cho bài mới , anh xem có cần sửa đổi gì không khi bài này chỉ lấy kết quả đầu tiên thôi .Việc thay đổi ô kết quả bắt đầu từ đâu cho nó giống trùng cột như ban đầu ,thân chào chúc anh nhiều may mắn và nhiều hạnh phúc