Help! VBA Tìm hàng cuối cùng trong phạm vi và sao lưu vào sheet khác

[NguyenDang88]

Xin chào anh chị em và các bạn,

Trước khi mình post bài đã search rất nhiều nhưng vẫn chưa tìm ra đáp án, nên vào đây nhờ mọi người đỡ ạ.

Hiện tại mình có bảng nhập như bên dưới (BẢNG 1), mình sẽ nhập số liệu vào cột F (cột tô vàng)



Sau đó mình sẽ save dữ liệu đã nhập (dòng đánh dấu "x") từ cột A : F vào BẢNG 2 như bên dưới



Mình có 2 vấn đề gặp phải ở đây:

1. Trước tiên mình đánh dấu "x" vào cột F để lọc và chép từ BẢNG 1 vào BẢNG 2
Nhưng mình muốn thay vì nhập "x" thì sẽ nhập hẳn số lượng luôn cho tiện (do mình k biết nên đánh dấu "x" để lọc cho dễ)

2. Khi sao chép, mình muốn chỉ chép dữ liệu đã lọc từ cột B : F
Nhưng đoạn code dưới đây đã chép toàn bộ từ cột A : XFD làm hỏng công thức và định dạng những cột phía sau (BẢNG 2)
Các bạn vui lòng tham khảo code bên dưới & file đính kèm cho rõ hơn.

P/S: Code này mình tham khảo rồi thêm bớt theo ý nên có gì không biết mọi người bỏ qua cho.
Xin cám ơn và vô cùng biết ơn anh chị em đã giúp đỡ và góp ý!

Sub ATR()
Application.ScreenUpdating = False
a = Worksheets("ATR").Cells(Rows.Count, 2).End(xlUp).Row

For i = 2 To a

If Worksheets("ATR").Cells(i, 6).Value = "x" Then

Worksheets("ATR").Rows(i).Copy
Worksheets("PK 2021").Activate
B = Worksheets("PK 2021").Cells(Rows.Count, 2).End(xlUp).Row
Worksheets("PK 2021").Cells(B + 1, 1).Select
ActiveSheet.Paste
Worksheets("ATR").Activate

End If
Next

Application.CutCopyMode = False

ThisWorkbook.Worksheets("ATR").Cells(1, 1).Select
Application.ScreenUpdating = True

End Sub

 

[Maika8008]

Đọc xong rốt cuộc không biết bạn kể chuyện hay là gì nữa.

 

[VetMini]

Đọc xong rốt cuộc không biết bạn kể chuyện hay là gì nữa.

Thớt có nói mình bị 2 vấn đề:

1. Thay vì lọc lấy theo "x" thì cần lọc bỏ những ô trống.

2. Code chép nhiều hơn mong muốn.

Mình có 2 vấn đề gặp phải ở đây:

1. Trước tiên mình đánh dấu "x" vào cột F để lọc và chép từ BẢNG 1 vào BẢNG 2
Nhưng mình muốn thay vì nhập "x" thì sẽ nhập hẳn số lượng luôn cho tiện (do mình k biết nên đánh dấu "x" để lọc cho dễ)

2. Khi sao chép, mình muốn chỉ chép dữ liệu đã lọc từ cột B : F
Nhưng đoạn code dưới đây đã chép toàn bộ từ cột A : XFD làm hỏng công thức và định dạng những cột phía sau (BẢNG 2)
Các bạn vui lòng tham khảo code bên dưới & file đính kèm cho rõ hơn.
...

 

[giaiphap]

Xin chào anh chị em và các bạn,

Trước khi mình post bài đã search rất nhiều nhưng vẫn chưa tìm ra đáp án, nên vào đây nhờ mọi người đỡ ạ.

Hiện tại mình có bảng nhập như bên dưới (BẢNG 1), mình sẽ nhập số liệu vào cột F (cột tô vàng)

View attachment 260624

Sau đó mình sẽ save dữ liệu đã nhập (dòng đánh dấu "x") từ cột A : F vào BẢNG 2 như bên dưới

View attachment 260622

Mình có 2 vấn đề gặp phải ở đây:

1. Trước tiên mình đánh dấu "x" vào cột F để lọc và chép từ BẢNG 1 vào BẢNG 2
Nhưng mình muốn thay vì nhập "x" thì sẽ nhập hẳn số lượng luôn cho tiện (do mình k biết nên đánh dấu "x" để lọc cho dễ)

2. Khi sao chép, mình muốn chỉ chép dữ liệu đã lọc từ cột B : F
Nhưng đoạn code dưới đây đã chép toàn bộ từ cột A : XFD làm hỏng công thức và định dạng những cột phía sau (BẢNG 2)
Các bạn vui lòng tham khảo code bên dưới & file đính kèm cho rõ hơn.

P/S: Code này mình tham khảo rồi thêm bớt theo ý nên có gì không biết mọi người bỏ qua cho.
Xin cám ơn và vô cùng biết ơn anh chị em đã giúp đỡ và góp ý!

Sub ATR()
Application.ScreenUpdating = False
a = Worksheets("ATR").Cells(Rows.Count, 2).End(xlUp).Row

For i = 2 To a

If Worksheets("ATR").Cells(i, 6).Value = "x" Then

Worksheets("ATR").Rows(i).Copy
Worksheets("PK 2021").Activate
B = Worksheets("PK 2021").Cells(Rows.Count, 2).End(xlUp).Row
Worksheets("PK 2021").Cells(B + 1, 1).Select
ActiveSheet.Paste
Worksheets("ATR").Activate

End If
Next

Application.CutCopyMode = False

ThisWorkbook.Worksheets("ATR").Cells(1, 1).Select
Application.ScreenUpdating = True

End Sub

Code thế này.

Sub ATR()
    Dim a As Integer, Arr(), dArr(), i As Integer, j As Integer, jRow As Integer
    a = Worksheets("ATR").Cells(Rows.Count, 2).End(xlUp).Row
    If a < 3 Then
        MsgBox "Khong co du lieu de copy"
        Exit Sub
    End If
    dArr = Range("B3:F" & a).Value
    ReDim Arr(1 To a, 1 To 5)
    jRow = 0
    For i = 1 To UBound(dArr)
        If dArr(i, 5) <> "" Then
            jRow = jRow + 1
            For j = 1 To 5
                Arr(jRow, j) = dArr(i, j)
            Next j
        End If
    Next i
    If jRow Then
        Sheet6.Range("B10000").End(xlUp).Offset(1).Resize(jRow, 5).Value = Arr
        MsgBox "Du lieu da duoc copy"
    End If
End Sub

 

[NguyenDang88]

Code thế này.

Sub ATR()
    Dim a As Integer, Arr(), dArr(), i As Integer, j As Integer, jRow As Integer
    a = Worksheets("ATR").Cells(Rows.Count, 2).End(xlUp).Row
    If a < 3 Then
        MsgBox "Khong co du lieu de copy"
        Exit Sub
    End If
    dArr = Range("B3:F" & a).Value
    ReDim Arr(1 To a, 1 To 5)
    jRow = 0
    For i = 1 To UBound(dArr)
        If dArr(i, 5) <> "" Then
            jRow = jRow + 1
            For j = 1 To 5
                Arr(jRow, j) = dArr(i, j)
            Next j
        End If
    Next i
    If jRow Then
        Sheet6.Range("B10000").End(xlUp).Offset(1).Resize(jRow, 5).Value = Arr
        MsgBox "Du lieu da duoc copy"
    End If
End Sub

Cám ơn bạn rất nhiều, mình làm được rồi. mừng quá!....
Chúc bạn mỗi ngày an lành & hạnh phúc!