根据单元格值在VBA中复制和粘贴循环

Question

我正在尝试创建一些查看一系列单元格的代码，并将符合特定参数的单元格复制并粘贴到工作簿中的其他位置。

我想从“sheet5”复制带有字母L的任何内容，并将特定范围复制到“sheet1”

我必须对代码的循环部分有问题，因为只复制了单元格区域的顶部。 我希望粘贴从第5行开始并继续向下移动。 这是否意味着我正确地将IRow = IRow + 1置于粘贴功能之下？

Sub Paste_Value_Test()

Dim c As Range
Dim IRow As Long
Dim rDestination As Excel.Range

Application.ScreenUpdating = False
Sheets("sheet5").Activate
For Each c In Sheets("sheet5").Range("b2", Range("N65536").End(xlUp))
    If c.Value = "L" Then
        Sheets("sheet5").Cells(c.Row, 2).Copy

        Set rDestination = Worksheets("sheet5").Cells(5 + IRow, 12)

        rDestination.Select
        Selection.PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, _
        SkipBlanks:=False, _
        Transpose:=False

        IRow = IRow + 1

    End If
Next c

End Sub

我真的很感激任何帮助。 我对VBA比较陌生，我会开始认真地挖掘。

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 "L" needs to be checked
    Set wsI = ThisWorkbook.Sheets("Sheet5")
    '~~> Output sheet
    Set wsO = ThisWorkbook.Sheets("Sheet1")

    Application.ScreenUpdating = False

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

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

        '~~> Search for the cell which has "L" and then copy it across to sheet1
        For Each c In rSource
            If c.Value = "L" Then
                .Cells(c.Row, 2).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