如果值> 0错误，则将行复制并粘贴到新工作表

Question

我正在处理一个包含多个工作表的Excel工作簿，在Sheet8上我有两个列（A和B），它通过基于A列的vlookup从所有工作表中提取数据，并在B列中返回0或> 0答案。

我一直在尝试使用宏来复制Sheet8上的行，其中B列中的值> 0并将它们完全粘贴到Sheet12或新工作簿中，但代码完全让我感到困惑。

下面是我正在使用的代码，它会抛出运行时错误9：下标超出范围错误。

Sub CSVCreate()

Dim rng As Range
Dim cell As Range
Dim lr As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheets("Sheet8")
Set ws2 = Sheets("Sheet12")

lr = ws1.Cells(Rows.Count, 1).End(xlUp).Row

Set rng = ws1.Range("B1:B" & lr)

For Each cell In rng
    If cell.Value > 0 Then
        cell.EntireRow.Copy
        If ws2.Range("A1").Value = "" Then
            ws2.Range("A1").PasteSpecial xlPasteValues
        Else
            ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        End If
    End If
Next cell

Application.CutCopyMode = False
Range("A1").Select

End Sub

任何帮助将非常感激！

谢谢，尼克

Answer 1

试试这个：

Option Explicit

Sub CSVCreate()

    Dim rng As Range, cell As Range
    Dim lr As Long
    Dim ws1 As Worksheet,ws2 As Worksheet

    With ThisWorkbook
        Set ws1 = .Sheets("Sheet8")
        Set ws2 = .Sheets("Sheet12")
    End With

    With ws1

        lr = .Cells(Rows.Count, 1).End(xlUp).Row

        Set rng = .Range("B1:B" & lr)

    End With

    For Each cell In rng

        If cell.Value > 0 Then

            cell.EntireRow.Copy

            With ws2

                If .Range("A1").Value = "" Then
                    .Range("A1").PasteSpecial xlPasteValues
                Else
                    .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                End If

            End With

        End If

    Next cell

    Application.CutCopyMode = False

End Sub

注意：

如果您在以下行中收到错误，则表示您没有此类工作表名称。

Set ws1 = .Sheets("Sheet8")
Set ws2 = .Sheets("Sheet12")