XÓA DÒNG TRONG EXCEL BẰNG VBA BỊ LỖI

thanhdo89 · 6/7/19

Anh chị nào xem giúp em đoạn code dưới đây được ko ạ,
e có nhiều sheet, trừ 5 sheet đầu ra, tính từ sheet thứ 6, em muốn bắt đầu từ dòng 13 trở đi ở cọt 11, nếu ko có gì thì xóa cả dòng, , sau đó copy toàn bộ dữ liệu bảng đó cũng từ dòng 13 đến hết rùi dán vào sheet 2PL2.
Em chỉ muốn xóa các dòng phía dưới dòng 13, nhưng chương trình lại xóa cả các dòng trên dòng 13, dẫn đến code vba của các đoạn sau của em chạy sai
Option Explicit
Sub A92_PHULUC2()
Dim J As Integer
On Error Resume Next
Sheets("2PL2").Range("P4:AG3258").Select
Selection.ClearContents
For J = 5 To Sheets.Count

Sheets(J).Activate
With ActiveSheet.Range("A13").CurrentRegion
.AutoFilter 11, Empty
.AutoFilter 9, ">0"
.Offset(1).Resize(, 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter

Range("A13").Select
Selection.CurrentRegion.Select
Selection.Offset(12, 0).Resize(Selection.Rows.Count - 1).Select '-1
Selection.Copy Destination:=Sheets("2PL2").Range("P4500").End(xlUp)(2)
End With
Next J
Sheets("2PL2").Activate
End Sub

snow25 · 6/7/19

thanhdo89 đã viết:
Anh chị nào xem giúp em đoạn code dưới đây được ko ạ,
e có nhiều sheet, trừ 5 sheet đầu ra, tính từ sheet thứ 6, em muốn bắt đầu từ dòng 13 trở đi ở cọt 11, nếu ko có gì thì xóa cả dòng, , sau đó copy toàn bộ dữ liệu bảng đó cũng từ dòng 13 đến hết rùi dán vào sheet 2PL2.
Em chỉ muốn xóa các dòng phía dưới dòng 13, nhưng chương trình lại xóa cả các dòng trên dòng 13, dẫn đến code vba của các đoạn sau của em chạy sai
Option Explicit
Sub A92_PHULUC2()
Dim J As Integer
On Error Resume Next
Sheets("2PL2").Range("P4:AG3258").Select
Selection.ClearContents
For J = 5 To Sheets.Count

Sheets(J).Activate
With ActiveSheet.Range("A13").CurrentRegion
.AutoFilter 11, Empty
.AutoFilter 9, ">0"
.Offset(1).Resize(, 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter

Range("A13").Select
Selection.CurrentRegion.Select
Selection.Offset(12, 0).Resize(Selection.Rows.Count - 1).Select '-1
Selection.Copy Destination:=Sheets("2PL2").Range("P4500").End(xlUp)(2)
End With
Next J
Sheets("2PL2").Activate
End Sub
View attachment 220567

Cho cái FIle lên xem nào bạn hay sợ bị lộ bí mật công ty.

thanhdo89 · 6/7/19

snow25 đã viết:
Cho cái FIle lên xem nào bạn hay sợ bị lộ bí mật công ty.

File đính kèm đây ạ. A xem giúp e với. E cám ơn anh ạ. Hj

Bài đã được tự động gộp: 6/7/19

snow25 · 6/7/19

thanhdo89 đã viết:
File đính kèm đây ạ. A xem giúp e với. E cám ơn anh ạ. Hj

Bài đã được tự động gộp: 6/7/19

Chả biết đúng hay sai vì dữ liệu bạn đưa lên không đúng với code.Bạn thử nhé.Mà trong code bạn sử dụng mảng mà.Sao không dùng mảng để kiểm tra điều kiện cho nó gọn.

Mã:

Sub A92_PHULUC2()
Dim J As Integer, lr As Long
'On Error Resume Next
Sheets("2PL2").Range("P4:AG3258").Select
Selection.ClearContents
For J = 5 To Sheets.Count

Sheets(J).Activate
lr = Range("A" & Rows.Count).End(xlUp).Row
If lr > 12 Then
With ActiveSheet.Range("A12:R" & lr)
.AutoFilter 11, Empty
.AutoFilter 9, ">0"
.Offset(1).Resize(, 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter

Range("A13").Select
Selection.CurrentRegion.Select
Selection.Offset(12, 0).Resize(Selection.Rows.Count - 1).Select '-1
Selection.Copy Destination:=Sheets("2PL2").Range("P4500").End(xlUp)(2)
End With
End If
Next J
Sheets("2PL2").Activate
End Sub

thanhdo89 · 7/7/19

Đây là file chuẩn của em, anh xem lại giúp em với, em đặt lệnh như anh vẫn ko được, và nó copy nó bỏ mất sheet đầu tiên của em, nó chỉ copy từ sheet thứ 2 của em trở đi, anh có thể giải thích giúp em đoạn code này (
Selection.Offset(12, 0).Resize(Selection.Rows.Count - 1).Select '-1
Selection.Copy Destination:=Sheets("2PL2").Range("P4500").End(xlUp)(2)
được ko ạ, em cám ơn ạ

snow25 đã viết:
Chả biết đúng hay sai vì dữ liệu bạn đưa lên không đúng với code.Bạn thử nhé.Mà trong code bạn sử dụng mảng mà.Sao không dùng mảng để kiểm tra điều kiện cho nó gọn.

Mã:

Sub A92_PHULUC2() Dim J As Integer, lr As Long 'On Error Resume Next Sheets("2PL2").Range("P4:AG3258").Select Selection.ClearContents For J = 5 To Sheets.Count Sheets(J).Activate lr = Range("A" & Rows.Count).End(xlUp).Row If lr > 12 Then With ActiveSheet.Range("A12:R" & lr) .AutoFilter 11, Empty .AutoFilter 9, ">0" .Offset(1).Resize(, 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete .AutoFilter Range("A13").Select Selection.CurrentRegion.Select Selection.Offset(12, 0).Resize(Selection.Rows.Count - 1).Select '-1 Selection.Copy Destination:=Sheets("2PL2").Range("P4500").End(xlUp)(2) End With End If Next J Sheets("2PL2").Activate End Sub

snow25 · 7/7/19

thanhdo89 đã viết:
Đây là file chuẩn của em, anh xem lại giúp em với, em đặt lệnh như anh vẫn ko được, và nó copy nó bỏ mất sheet đầu tiên của em, nó chỉ copy từ sheet thứ 2 của em trở đi, anh có thể giải thích giúp em đoạn code này (
Selection.Offset(12, 0).Resize(Selection.Rows.Count - 1).Select '-1
Selection.Copy Destination:=Sheets("2PL2").Range("P4500").End(xlUp)(2)
được ko ạ, em cám ơn ạ

Bạn nói yêu cầu đi mình viết code khác nhé.

thanhdo89 · 7/7/19

snow25 đã viết:
Bạn nói yêu cầu đi mình viết code khác nhé.

Dạ, em muốn trong các sheet trừ 4 sheet đầu (1DSDB; 2PL2; 3PL4; 4TH), bắt đầu từ sheet thứ 5, bắt đầu tư dòng 13 nếu cột hộ mẫu (cột K= Empty) thì em xóa bỏ các dòng đó đi, và em muốn copy toàn bộ những hộ mẫu được chọn (cột K =1) thì copy dán dữ liệu những hộ đấy vào ô bắt đầu từ ô P4 của sheet "2PL2", anh xem giúp em với, em cám ơn ạ

snow25 · 7/7/19

thanhdo89 đã viết:
Dạ, em muốn trong các sheet trừ 4 sheet đầu (1DSDB; 2PL2; 3PL4; 4TH), bắt đầu từ sheet thứ 5, bắt đầu tư dòng 13 nếu cột hộ mẫu (cột K= Empty) thì em xóa bỏ các dòng đó đi, và em muốn copy toàn bộ những hộ mẫu được chọn (cột K =1) thì copy dán dữ liệu những hộ đấy vào ô bắt đầu từ ô P4 của sheet "2PL2", anh xem giúp em với, em cám ơn ạ

Bạn xem có đúng không nhé.

Mã:

Sub gopdulieu()
    Dim arr, i As Long, j As Long, dk As String, kq, lr As Long, a As Long, max As Long, sh As Worksheet, ten As String
    ten = "#1DSDB#2PL2#3PL4#4TH#"
    For Each sh In ThisWorkbook.Worksheets
        If InStr(1, ten, "#" & sh.Name & "#") = 0 Then
           lr = sh.Range("B" & Rows.Count).End(xlUp).Row
           max = max + lr
        End If
   Next
   ReDim kq(1 To max, 1 To 17)
    For Each sh In ThisWorkbook.Worksheets
        If InStr(1, ten, "#" & sh.Name & "#") = 0 Then
           lr = sh.Range("B" & Rows.Count).End(xlUp).Row
           If lr > 12 Then
              arr = sh.Range("B13:R" & lr).Value
              For i = 1 To UBound(arr)
                 If arr(i, 10) = 1 Then
                    a = a + 1
                    For j = 1 To 17
                        kq(a, j) = arr(i, j)
                    Next j
                 End If
              Next i
          End If
       End If
    Next
    With Sheets("2PL2")
         lr = .Range("Q" & Rows.Count).End(xlUp).Row
         If lr > 3 Then .Range("Q4:AG" & lr).ClearContents
         If a Then .Range("Q4:AG4").Resize(a).Value = kq
    End With
End Sub

thanhdo89 · 7/7/19

snow25 đã viết:

Bạn xem có đúng không nhé.

Mã:

Sub gopdulieu()
    Dim arr, i As Long, j As Long, dk As String, kq, lr As Long, a As Long, max As Long, sh As Worksheet, ten As String
    ten = "#1DSDB#2PL2#3PL4#4TH#"
    For Each sh In ThisWorkbook.Worksheets
        If InStr(1, ten, "#" & sh.Name & "#") = 0 Then
           lr = sh.Range("B" & Rows.Count).End(xlUp).Row
           max = max + lr
        End If
   Next
   ReDim kq(1 To max, 1 To 17)
    For Each sh In ThisWorkbook.Worksheets
        If InStr(1, ten, "#" & sh.Name & "#") = 0 Then
           lr = sh.Range("B" & Rows.Count).End(xlUp).Row
           If lr > 12 Then
              arr = sh.Range("B13:R" & lr).Value
              For i = 1 To UBound(arr)
                 If arr(i, 10) = 1 Then
                    a = a + 1
                    For j = 1 To 17
                        kq(a, j) = arr(i, j)
                    Next j
                 End If
              Next i
          End If
       End If
    Next
    With Sheets("2PL2")
         lr = .Range("Q" & Rows.Count).End(xlUp).Row
         If lr > 3 Then .Range("Q4:AG" & lr).ClearContents
         If a Then .Range("Q4:AG4").Resize(a).Value = kq
    End With
End Sub

Vẫn ko được anh ơi, em muốn copy cả cột A nữa, anh chỉ để vậy cột b cho e, và em muốn dán liệu vào cột P chứ ko phải Q (trong sheet 2PL2, e đã thay đổi Q =P, B = A, thì nó vẫn bị mất mấy dòng đầu anh ạ, anh xem lại giúp em với,

snow25 · 7/7/19

thanhdo89 đã viết:
Vẫn ko được anh ơi, em muốn copy cả cột A nữa, anh chỉ để vậy cột b cho e, và em muốn dán liệu vào cột P chứ ko phải Q (trong sheet 2PL2, e đã thay đổi Q =P, B = A, thì nó vẫn bị mất mấy dòng đầu anh ạ, anh xem lại giúp em với,

Bạn xem lại nhé.Mình thấy đủ mà.

Mã:

Sub gopdulieu()
    Dim arr, i As Long, j As Long, dk As String, kq, lr As Long, a As Long, max As Long, sh As Worksheet, ten As String
    ten = "#1DSDB#2PL2#3PL4#4TH#"
    For Each sh In ThisWorkbook.Worksheets
        If InStr(1, ten, "#" & sh.Name & "#") = 0 Then
           lr = sh.Range("B" & Rows.Count).End(xlUp).Row
           max = max + lr
        End If
   Next
   ReDim kq(1 To max, 1 To 18)
    For Each sh In ThisWorkbook.Worksheets
        If InStr(1, ten, "#" & sh.Name & "#") = 0 Then
           lr = sh.Range("B" & Rows.Count).End(xlUp).Row
           If lr > 12 Then
              arr = sh.Range("A13:R" & lr).Value
              For i = 1 To UBound(arr)
                 If arr(i, 11) = 1 Then
                    a = a + 1
                    For j = 1 To 18
                        kq(a, j) = arr(i, j)
                    Next j
                 End If
              Next i
          End If
       End If
    Next
    With Sheets("2PL2")
         lr = .Range("Q" & Rows.Count).End(xlUp).Row
         If lr > 3 Then .Range("p4:AG" & lr).ClearContents
         If a Then .Range("p4:AG4").Resize(a).Value = kq
    End With
End Sub

thanhdo89 · 7/7/19

snow25 đã viết:

Bạn xem lại nhé.Mình thấy đủ mà.

Mã:

Sub gopdulieu()
    Dim arr, i As Long, j As Long, dk As String, kq, lr As Long, a As Long, max As Long, sh As Worksheet, ten As String
    ten = "#1DSDB#2PL2#3PL4#4TH#"
    For Each sh In ThisWorkbook.Worksheets
        If InStr(1, ten, "#" & sh.Name & "#") = 0 Then
           lr = sh.Range("B" & Rows.Count).End(xlUp).Row
           max = max + lr
        End If
   Next
   ReDim kq(1 To max, 1 To 18)
    For Each sh In ThisWorkbook.Worksheets
        If InStr(1, ten, "#" & sh.Name & "#") = 0 Then
           lr = sh.Range("B" & Rows.Count).End(xlUp).Row
           If lr > 12 Then
              arr = sh.Range("A13:R" & lr).Value
              For i = 1 To UBound(arr)
                 If arr(i, 11) = 1 Then
                    a = a + 1
                    For j = 1 To 18
                        kq(a, j) = arr(i, j)
                    Next j
                 End If
              Next i
          End If
       End If
    Next
    With Sheets("2PL2")
         lr = .Range("Q" & Rows.Count).End(xlUp).Row
         If lr > 3 Then .Range("p4:AG" & lr).ClearContents
         If a Then .Range("p4:AG4").Resize(a).Value = kq
    End With
End Sub

Dạ e cám ơn a ạ. Để chiều e xem lại

XÓA DÒNG TRONG EXCEL BẰNG VBA BỊ LỖI

thanhdo89

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

snow25

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

thanhdo89

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

File đính kèm

snow25

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

thanhdo89

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

File đính kèm

snow25

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

thanhdo89

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

File đính kèm

snow25

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

thanhdo89

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

snow25

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

File đính kèm

thanhdo89

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

Bài viết mới nhất

Facebook

Group

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