Copy nhiều dòng dữ liệu bị ngắt quãng bởi dòng dữ liệu trắng

lehoctk · 18/4/22

Chào cả nhà, em có file demo dữ liệu đính kèm, rất mong được góp ý ạ,
Em đang cần sao chép các dòng dữ liệu ở sheet1 (mà dữ liệu ở cột A khác trống) và dán sang sheet2 .
Em cảm ơn tất cả mọi người đã quan tâm và trợ giúp ạ.

Hoàng Tuấn 868 · 18/4/22

lehoctk đã viết:
cần sao chép các dòng dữ liệu ở sheet1 (mà dữ liệu ở cột A khác trống) và dán sang sheet2

Tham khảo. . . . .

BuiQuangThuan · 18/4/22

lehoctk đã viết:
Em cảm ơn tất cả mọi người đã quan tâm và trợ giúp ạ.

Thêm cách khác tham khảo:

Mã:

Sub ABC()
    Dim Rng As Range
    Set Rng = Sheets("sheet1").Range("A1:B" & Sheets("sheet1").Range("B" & Rows.Count).End(3).Row)
    Sheets("sheet2").Range("A:B").ClearContents
    Rng.AutoFilter 1, "<>"
    Rng.SpecialCells(12).Copy Sheets("Sheet2").Range("A1")
    Sheets("sheet1").AutoFilterMode = False
End Sub

Maika8008 · 18/4/22

BuiQuangThuan đã viết:

Thêm cách khác tham khảo:

Mã:

Sub ABC()
    Dim Rng As Range
    Set Rng = Sheets("sheet1").Range("A1:B" & Sheets("sheet1").Range("B" & Rows.Count).End(3).Row)
    Sheets("sheet2").Range("A:B").ClearContents
    Rng.AutoFilter 2, "<>"
    Rng.SpecialCells(12).Copy Sheets("Sheet2").Range("A1")
    Sheets("sheet1").AutoFilterMode = False
End Sub

Nếu A trống mà B không trống thì code chạy sai á ! Thớt muốn chỉ A không trống mới chép chứ B không đi theo A như ví dụ thì sao?

BuiQuangThuan · 18/4/22

Maika8008 đã viết:
Nếu A trống mà B không trống thì code chạy sai á ! Thớt muốn chỉ A không trống mới chép chứ B không đi theo A như ví dụ thì sao?

Em nhầm xíu. Đã sửa lại #3

lehoctk · 18/4/22

Hoàng Tuấn 868 đã viết:
Tham khảo. . . . .

Cảm ơn tiền bối đã góp ý. Nhưng em xin phép trao đổi thêm về ý tưởng (mong bác có góp ý để hiện thực hóa ý tưởng).
Em đang nghĩ đến việc dùng xlDown nhưng gặp trường hợp vùng cần copy có 1 dòng thì sẽ bị lỗi, em chưa biết cách khắc phục.
Em thiết nghĩ với cách dùng xlDown thì số vòng lặp sẽ ít hơn vòng For có đúng không bác, mong bác chỉ giáo ạ.
Một lần nữa cảm ơn bác rất nhiều.

Bài đã được tự động gộp: 18/4/22

Maika8008 đã viết:
Nếu A trống mà B không trống thì code chạy sai á ! Thớt muốn chỉ A không trống mới chép chứ B không đi theo A như ví dụ thì sao?

Cảm ơn tiền bối đã góp ý. Mong muốn của em là điều kiện theo cột A thôi bác ạ.

Maika8008 · 18/4/22

lehoctk đã viết:
Chào cả nhà, em có file demo dữ liệu đính kèm, rất mong được góp ý ạ,
Em đang cần sao chép các dòng dữ liệu ở sheet1 (mà dữ liệu ở cột A khác trống) và dán sang sheet2 .
Em cảm ơn tất cả mọi người đã quan tâm và trợ giúp ạ.

Thử code ngăn ngắn sau xem sao:

Rich (BB code):

Sub CopyCellsNotBlank()
Dim Rng As Range
    Set Rng = Sheets("sheet1").Range("A1:A" & Sheets("sheet1").Range("B" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeConstants)
    Sheets("sheet2").Range("A1:B50000").ClearContents
    Rng.EntireRow.Copy Sheets("Sheet2").Range("A1")
End Sub

lehoctk · 18/4/22

Maika8008 đã viết:
Thử code ngăn ngắn sau xem sao:

Rich (BB code):

Sub CopyCellsNotBlank() Dim Rng As Range Set Rng = Sheets("sheet1").Range("A1:A" & Sheets("sheet1").Range("B" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeConstants) Sheets("sheet2").Range("A1:B50000").ClearContents Rng.EntireRow.Copy Sheets("Sheet2").Range("A1") End Sub

Giải pháp của bác code khá ngắn gọn ạ, nhưng cho cho em xin thêm chút ý kiến làm sao để copy các cột dữ liệu tùy chọn mà không phải copy hết cả dòng không ạ. Ví dụ em cần copy cột A, C,D,F nếu các dòng ở A khác rỗng đấy ạ.
Cảm ơn các bác rất nhiều.

bebo021999 · 18/4/22

Thử:

PHP:

Option Explicit
Sub test()
Dim lr&
Worksheets("Sheet2").Range("A:F").ClearContents
With Worksheets("Sheet1")
    .AutoFilterMode = False
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    .Range("A1:A" & lr).AutoFilter 1, "<>"
    .Range("A1:F" & lr).SpecialCells(xlVisible).Copy Worksheets("Sheet2").Range("A1")
    .AutoFilterMode = False
    Application.CutCopyMode = False
End With
Union(Worksheets("Sheet2").Range("B1").EntireColumn, Worksheets("Sheet2").Range("E1").EntireColumn).Delete
End Sub

lehoctk · 18/4/22

bebo021999 đã viết:

Thử:

PHP:

Option Explicit
Sub test()
Dim lr&
Worksheets("Sheet2").Range("A:F").ClearContents
With Worksheets("Sheet1")
    .AutoFilterMode = False
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    .Range("A1:A" & lr).AutoFilter 1, "<>"
    .Range("A1:F" & lr).SpecialCells(xlVisible).Copy Worksheets("Sheet2").Range("A1")
    .AutoFilterMode = False
    Application.CutCopyMode = False
End With
Union(Worksheets("Sheet2").Range("B1").EntireColumn, Worksheets("Sheet2").Range("E1").EntireColumn).Delete
End Sub

Cảm ơn bác rất nhiều ạ.
Em có 1 mong muốn bổ sung so với bảng đã gửi mong nhận được chia sẻ, đàm đạo thêm của các tiền bối ạ.
Như trong file đính kèm bổ sung ở cột A là cột khu vực và các cột còn lại là dữ liệu chi tiết của các khu vực tương ứng dạng Sub Total ấy ạ.
Giờ làm sao để copy dữ liệu sang Sheet2 theo cấu trúc như dữ liệu em đã gán ở bên Sheet2 để minh họa rồi ạ
Một lần nữa em cảm ơn các tiền bối đã chia sẻ ạ.

Maika8008 · 18/4/22

lehoctk đã viết:
Giải pháp của bác code khá ngắn gọn ạ, nhưng cho cho em xin thêm chút ý kiến làm sao để copy các cột dữ liệu tùy chọn mà không phải copy hết cả dòng không ạ. Ví dụ em cần copy cột A, C,D,F nếu các dòng ở A khác rỗng đấy ạ.
Cảm ơn các bác rất nhiều.

Thế thì nó sẽ không còn ngắn gọn nữa.

Hoàng Tuấn 868 · 18/4/22

Vụ này từ bài đầu đến #10 đã bổ sung và đổi ý đến 3 lần rồi. Sao không chốt 1 lần cho xong đi nhỉ.

bebo021999 · 18/4/22

PHP:

Option Explicit
Sub Test()
Dim lr&, i&, j&, k&, kv, arr, arrb(1 To 65000, 1 To 6)
With Worksheets("Sheet2")
arr = Worksheets("Sheet1").Range("A1:G" & Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row).Value
    For i = 1 To UBound(arr)
        If arr(i, 1) <> "" Then kv = arr(i, 1)
        If arr(i, 2) <> "" Then
            k = k + 1
            arrb(k, 1) = kv
            For j = 2 To 5
                arrb(k, j) = arr(i, j)
            Next
                arrb(k, 6) = arr(i, 7)
        End If
    Next
.Range("A1:G100000").ClearContents
.Range("A1").Resize(k, 6).Value = arrb
End With
End Sub

VetMini · 18/4/22

Cái này rõ ràng là chức năng của Advanced Filter mà.
Đổ công sức viết code để tiết kiệm vài cái click chuột? Hay là xin code VBA dễ quá rồi người ta lười học các công cụ căn bản của Excel?

lehoctk · 18/4/22

Hoàng Tuấn 868 đã viết:
Vụ này từ bài đầu đến #10 đã bổ sung và đổi ý đến 3 lần rồi. Sao không chốt 1 lần cho xong đi nhỉ.

Vì đây không phải là bài toán cố định mà em tự đặt ra yêu cầu để học tập và trong quá trình đặt ra câu hỏi thì phát sinh thêm ý tưởng ạ, mong bác thông cảm cho em ạ.

Bài đã được tự động gộp: 18/4/22

VetMini đã viết:
Cái này rõ ràng là chức năng của Advanced Filter mà.
Đổ công sức viết code để tiết kiệm vài cái click chuột? Hay là xin code VBA dễ quá rồi người ta lười học các công cụ căn bản của Excel?

Cảm ơn bác đã chia sẻ ạ, em xin phản hồi bác như sau: em có biết về Advanced Filter, nhưng đây là vấn đề em tự đặt ra để tìm thêm các hướng giải quyết vấn đề nhằm mục đích học tập ạ, mong bác thông cảm.

Bài đã được tự động gộp: 18/4/22

bebo021999 đã viết:

PHP:

Option Explicit
Sub Test()
Dim lr&, i&, j&, k&, kv, arr, arrb(1 To 65000, 1 To 6)
With Worksheets("Sheet2")
arr = Worksheets("Sheet1").Range("A1:G" & Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row).Value
    For i = 1 To UBound(arr)
        If arr(i, 1) <> "" Then kv = arr(i, 1)
        If arr(i, 2) <> "" Then
            k = k + 1
            arrb(k, 1) = kv
            For j = 2 To 5
                arrb(k, j) = arr(i, j)
            Next
                arrb(k, 6) = arr(i, 7)
        End If
    Next
.Range("A1:G100000").ClearContents
.Range("A1").Resize(k, 6).Value = arrb
End With
End Sub

Cảm ơn tiền bối rất nhiều ạ.

Bài đã được tự động gộp: 18/4/22

BuiQuangThuan đã viết:

Thêm cách khác tham khảo:

Mã:

Sub ABC()
    Dim Rng As Range
    Set Rng = Sheets("sheet1").Range("A1:B" & Sheets("sheet1").Range("B" & Rows.Count).End(3).Row)
    Sheets("sheet2").Range("A:B").ClearContents
    Rng.AutoFilter 1, "<>"
    Rng.SpecialCells(12).Copy Sheets("Sheet2").Range("A1")
    Sheets("sheet1").AutoFilterMode = False
End Sub

Cảm ơn tiền bối ạ

batman1 · 18/4/22

lehoctk đã viết:
Cảm ơn tiền bối rất nhiều ạ.

Bài đã được tự động gộp: 18/4/22

Cảm ơn tiền bối ạ

Không hểu lắm. Tiền giấy, tiền vàng, tiền thật, tiền giả, tiền xu, thậm chí tiền thối (nặng mùi?

) đều đã nghe rồi. Không biết tiền bối là tiền gì vậy bạn?

lehoctk · 18/4/22

batman1 đã viết:
Không hểu lắm. Tiền giấy, tiền vàng, tiền thật, tiền giả, tiền xu, thậm chí tiền thối (nặng mùi? ) đều đã nghe rồi. Không biết tiền bối là tiền gì vậy bạn?

Em không biết xưng hô sao cho phù hợp, bác bỏ qua nhé.

batman1 · 18/4/22

lehoctk đã viết:
Em không biết xưng hô sao cho phù hợp, bác bỏ qua nhé.

Không biết xưng hô sao phù hợp, vậy sao bạn dùng từ "bác" với tôi? Cũng y hệt bạn có thể dùng từ "bác" với họ mà.

lehoctk · 18/4/22

batman1 đã viết:
Không biết xưng hô sao phù hợp, vậy sao bạn dùng từ "bác" với tôi? Cũng y hệt bạn có thể dùng từ "bác" với họ mà.

Vâng, em đã điều chỉnh rồi đó bác.

VetMini · 18/4/22

lehoctk đã viết:
...
Cảm ơn bác đã chia sẻ ạ, em xin phản hồi bác như sau: em có biết về Advanced Filter, nhưng đây là vấn đề em tự đặt ra để tìm thêm các hướng giải quyết vấn đề nhằm mục đích học tập ạ, mong bác thông cảm.

Có thể người khác dễ dãi chứ tôi có nguyên tắc của mình, khó thông cảm chuyện này lắm.
Nếu bạn chỉ "nhằm mục đích học tập" thì nêu rõ ý định từ đầu trong bài #1.
Vả lại, người muốn học tập thì tự tìm lấy một vài phương pháp thủ công rồi record macro để , chỗ nào khó hiểu hoặc cần ưu hóa thì đưa lên đây hỏi. Bạn đưa ra mệnh đề "Em đang cần" ở đây là kém phần chân thật. Ý bạn chỉ muốn đọc code của người khác mà mập mờ không chịu tiết lộ.

Chung quy thì tôi vạch rõ Advanced Filter là cách làm chính thống với mục đích chia sẻ với các bạn khác trong diễn đàn : chớ đi vào con đường cho rằng VBA sẽ giải quyết mọi công việc.

Copy nhiều dòng dữ liệu bị ngắt quãng bởi dòng dữ liệu trắng

Thành viên chính thức

File đính kèm

Đăng ký hôm qua

File đính kèm

❆❆❆❆❆❆❆❆❆❆❆❆

Thành viên gạo cội

❆❆❆❆❆❆❆❆❆❆❆❆

Thành viên chính thức

Thành viên gạo cội

Thành viên chính thức

Thành viên gạo cội

Thành viên chính thức

File đính kèm

Thành viên gạo cội

Đăng ký hôm qua

Thành viên gạo cội

Ăn cùng góc phố

Thành viên chính thức

Thành viên gạo cội

Thành viên chính thức

Thành viên gạo cội

Thành viên chính thức

Ăn cùng góc phố