根據單元格值在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