仅当所选列中的单元格不为空时才复制行

Question

下面的代码（代码一）目前工作正常，其中选定的列被复制并粘贴到 A 列中的单个条件。

但是，我正在尝试添加另一个条件，如果 N 到 R 列为空，excel 将不会复制单元格。我尝试编写代码二（下方），但出现运行时间错误“9”下标超出范围。

能否请我帮忙更改代码二，以便正确过滤列。

代码一

Dim i As Long
Dim iLastRow As Long
Dim iTarget As Long

With Worksheets("Okay")

    iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    For i = 1 To iLastRow
        If .Cells(i, "A").Value = "Welcome" Then
            iTarget = iTarget + 1
            .Cells(i, "B").Copy
            Worksheets("Sheet7").Range("A" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "C").Copy
            Worksheets("Sheet7").Range("B" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "D").Copy
            Worksheets("Sheet7").Range("C" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "E").Copy
            Worksheets("Sheet7").Range("D" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "F").Copy
            Worksheets("Sheet7").Range("F" & iTarget + 1).PasteSpecial xlPasteValues
            Worksheets("Sheet7").Range("G" & iTarget + 1).Value = "How"
            Worksheets("Sheet7").Range("H" & iTarget + 1).Value = "Are"
            Worksheets("Sheet7").Range("I" & iTarget + 1).Value = "You"
            Worksheets("Sheet7").Range("J" & iTarget + 1).Value = "Okay"
            .Cells(i, "N").Copy
            Worksheets("Sheet7").Range("K" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "O").Copy
            Worksheets("Sheet7").Range("L" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "P").Copy
            Worksheets("Sheet7").Range("M" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "Q").Copy
            Worksheets("Sheet7").Range("N" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "R").Copy
            Worksheets("Sheet7").Range("O" & iTarget + 1).PasteSpecial xlPasteValues
        End If
    Next i

End With

代码二

Dim i As Long
Dim iLastRow As Long
Dim iTarget As Long

With Worksheets("Okay")

    iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    For i = 1 To iLastRow
        If .Cells(i, "A").Value = "Welcome" Then
        If .Cells(i, "N").Value <> "" Then
        If .Cells(i, "O").Value <> "" Then
        If .Cells(i, "P").Value <> "" Then
        If .Cells(i, "Q").Value <> "" Then
        If .Cells(i, "R").Value <> "" Then
            iTarget = iTarget + 1
            .Cells(i, "B").Copy
            Worksheets("Sheet7").Range("A" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "C").Copy
            Worksheets("Sheet7").Range("B" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "D").Copy
            Worksheets("Sheet7").Range("C" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "E").Copy
            Worksheets("Sheet7").Range("D" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "F").Copy
            Worksheets("Sheet7").Range("F" & iTarget + 1).PasteSpecial xlPasteValues
            Worksheets("Sheet7").Range("G" & iTarget + 1).Value = "Hello"
            Worksheets("Sheet7").Range("H" & iTarget + 1).Value = "How"
            Worksheets("Sheet7").Range("I" & iTarget + 1).Value = "Are"
            Worksheets("Sheet7").Range("J" & iTarget + 1).Value = "You"
            .Cells(i, "N").Copy
            Worksheets("Sheet7").Range("K" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "O").Copy
            Worksheets("Sheet7").Range("L" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "P").Copy
            Worksheets("Sheet7").Range("M" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "Q").Copy
            Worksheets("Sheet7").Range("N" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "R").Copy
            Worksheets("Sheet7").Range("O" & iTarget + 1).PasteSpecial xlPasteValues
            .Cells(i, "G").Copy
            Worksheets("Sheet7").Range("P" & iTarget + 1).PasteSpecial xlPasteValues
        End If
        End If
        End If
        End If
        End If
        End If
    Next i

End With

Answer 1

如果您收到 "subscript out of range" 行错误

Worksheets("Sheet7").Range("A" & iTarget + 1).PasteSpecial xlPasteValues

那么最可能的原因（或者我认为是唯一的原因）是您没有名为 "Sheet7".

的工作表

注意：您可以通过不使用 Copy/Paste 来改进您的代码。 Copy/Paste 很慢，如果您的用户在等待您的宏运行时在其他应用程序中执行另一个手动 copy/paste，也会导致问题。试试这个稍微重构的代码：

Dim i As Long
Dim iLastRow As Long
Dim iTarget As Long
iTarget = 1 ' initialise value to avoid lots of "+ 1"s

With Worksheets("Okay")    
    iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    For i = 1 To iLastRow
        If .Cells(i, "A").Value = "Welcome" Then
        If .Cells(i, "N").Value <> "" Then
        If .Cells(i, "O").Value <> "" Then
        If .Cells(i, "P").Value <> "" Then
        If .Cells(i, "Q").Value <> "" Then
        If .Cells(i, "R").Value <> "" Then
            iTarget = iTarget + 1
            'Set 4 columns at once
            Worksheets("Sheet7").Range("A" & iTarget).Resize(1, 4).Value = .Cells(i, "B").Resize(1, 4).Value
            Worksheets("Sheet7").Range("F" & iTarget).Value = .Cells(i, "F").Value
            Worksheets("Sheet7").Range("G" & iTarget).Value = "Hello"
            Worksheets("Sheet7").Range("H" & iTarget).Value = "How"
            Worksheets("Sheet7").Range("I" & iTarget).Value = "Are"
            Worksheets("Sheet7").Range("J" & iTarget).Value = "You"
            'Set 5 columns at once
            Worksheets("Sheet7").Range("K" & iTarget).Resize(1, 5).Value = .Cells(i, "N").Resize(1, 5).Value
            Worksheets("Sheet7").Range("P" & iTarget).Value = .Cells(i, "G").Value
        End If
        End If
        End If
        End If
        End If
        End If
    Next i    
End With

仅当所选列中的单元格不为空时才复制行

Copy rows only if cells are not blank in selected columns

excel

vba

copy-paste

multiple-columns