Макрос для копирования и вставки строк на новый лист, если значение> 0 ошибка

Question

Я работаю над книгой Excel с несколькими листами, на Листе 8 у меня есть два столбца (A & B), которые извлекают данные со всех листов с помощью vlookup, основанного на столбце A, и возвращают ответ 0 или> 0 встолбец B.

Я пытался получить макрос, чтобы скопировать строки в 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")