时间戳

首页 > 解决方案 > 如果值 > 0 错误，则将行复制并粘贴到新工作表的宏

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

问题描述

我正在处理具有多张工作表的 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

任何帮助将非常感激！

谢谢，尼克

标签： excelvba

解决方案

试试这个：

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")

推荐阅读