vba - Excel VBA - 根据单元格值在 VBA 中复制并粘贴循环

Question

我试图想出一个宏来检查单元格中是否存在任何数字值。如果存在数字值，请复制该行的一部分并将其粘贴到同一电子表格内的另一个工作表中。

Sheet1 是包含我所有数据的工作表。我正在尝试查看 R 列中是否有任何值。如果是，请复制该单元格及其左侧的四个相邻单元格，然后将其粘贴到 Sheet2 中。

这是我迄今为止基于混搭其他人的代码而想出的结果，尽管它只完成了我想要的一部分。它只是复制行的一部分，然后将其粘贴到另一个工作表中，但它不会首先检查 R 列的值。不管怎样，它只是复制和粘贴，并且一旦完成就不会移动到下一行。我需要它继续到下一行继续查找:

Sub Paste_Value_Test()

Dim c As Range
Dim IRow As Long, lastrow As Long
Dim rSource As Range
Dim wsI As Worksheet, wsO As Worksheet

On Error GoTo Whoa

'~~> Sheet Where values needs to be checked
Set wsI = ThisWorkbook.Sheets("Sheet1")
'~~> Output sheet
Set wsO = ThisWorkbook.Sheets("Sheet2")

Application.ScreenUpdating = False

With wsI
    '~~> Find Last Row which has data in Col O to R
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        lastrow = .Columns("O:R").Find(What:="*", _
                      After:=.Range("O3"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
    Else
        lastrow = 1
    End If

    '~~> Set you input range
    Set rSource = .Range("R" & lastrow)

    '~~> Search for the cell which has "L" and then copy it across to sheet1
    For Each c In rSource
    Debug.Print cValue
        If c.Value > "0" Then
            .Range("O" & c.Row & ":R" & c.Row).Copy
            wsO.Cells(5 + IRow, 12).PasteSpecial Paste:=xlPasteValues
            IRow = IRow + 1
        End If
    Next
End With

LetsContinue:
Application.ScreenUpdating = True
Application.CutCopyMode = False
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub

Answer 1

下面是一些代码，希望能够实现我认为您想要做的事情。我在整个过程中都添加了评论，说明了我所做的更改:

Sub Paste_Value_Test()

    Dim c As Range
    Dim IRow As Long, lastrow As Long
    Dim rSource As Range
    Dim wsI As Worksheet, wsO As Worksheet

    On Error GoTo Whoa

    '~~> Sheet Where values needs to be checked
    Set wsI = ThisWorkbook.Sheets("Sheet1")
    '~~> Output sheet
    Set wsO = ThisWorkbook.Sheets("Sheet2")

    Application.ScreenUpdating = False

    With wsI
        '~~> Find Last Row which has data in Col O to R
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            'You specified "After" to be cell O3.  This means a match will
            '  occur on row 2 if cell R2 (or O2 or P2) has something in it
            '  because cell R2 is the cell "after" O3 when
            '  "SearchDirection:=xlPrevious"

            '             After:=.Range("O3"), _

            lastrow = .Columns("O:R").Find(What:="*", _
                          After:=.Range("O1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
        Else
            lastrow = 1
        End If

        'This was only referring to the single cell in column R on the
        '  last row (in columns O:R)
        'Set rSource = .Range("R" & lastrow)
        'Create a range referring to everything in column R, from row 1
        '  down to the "last row"
        Set rSource = .Range("R1:R" & lastrow)

        'This comment doesn't seem to reflect what the code was doing, or what the
        'question said
        '~~> Search for the cell which has "L" and then copy it across to sheet1
        For Each c In rSource
            'This is printing the variable "cValue", which has never been set
            'Debug.Print cValue
            'It was probably meant to be
            Debug.Print c.Value
            'This was testing whether the value in the cell was
            '  greater than the string "0"
            'So the following values would be > "0"
            '  ABC
            '  54
            '  ;asd
            'And the following values would not be > "0"
            '  (ABC)
            '  $523   (assuming that was as text, and not just 523 formatted as currency)
            'If c.Value > "0" Then
            'I suspect you are trying to test whether the cell is numeric
            '  and greater than 0
            If IsNumeric(c.Value) Then
                If c.Value > 0 Then
                    'This is only copying the cell and the *three* cells
                    ' to the left of it
                    '.Range("O" & c.Row & ":R" & c.Row).Copy
                    'This will copy the cell and the *four* cells
                    ' to the left of it
                    '.Range("N" & c.Row & ":R" & c.Row).Copy
                    'wsO.Cells(5 + IRow, 12).PasteSpecial Paste:=xlPasteValues
                    'But this would avoid the use of copy/paste
                    wsO.Cells(5 + IRow, 12).Resize(1, 5).Value = _
                         .Range("N" & c.Row & ":R" & c.Row).Value
                    IRow = IRow + 1
                End If
            End If
        Next
    End With

LetsContinue:
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub