CODEWITHSUNDEEP
vbaexcelfor-loop
dutchballa
dutchballa

Reputation: 79

Copy and Paste Loop in VBA based on cell values

I am trying to create some code that looks through a range of cells and will copy and paste the cells that meet a specific parameter to a different location in the workbook.

I would like to copy anything with the letter L from "sheet5" and copy a specific range to "sheet1"

I must have something wrong with the loop part of the code because only the top of the cell range is being copied. I would like the pasting to start at row 5 and continue moving downward. Does this mean I correctly put the IRow = IRow + 1 below the paste function?

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

I really appreciate any help on this. I'm relatively new to VBA and am going to start seriously digging in.

Upvotes: 1

Views: 28443

Answers (1)

Siddharth Rout
Siddharth Rout

Reputation: 149335

Is this what you are trying by any chance? I have commented the code so you shouldn't have any problem understanding it.

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

Upvotes: 3

Related Questions