Looping and pasting based on cell value-CodePudding

i have started this code, which looks in worksheet PCrun for "yes" in cell D2 then then copies A1:C9 and paste as an image to worksheet PCexport starting at cell A1. This works but there are a few more steps i am stuck on. I would like it to move on to the next range of cells A10:C18 looking in cell D11 for a yes. This needs to continue i.e D2 - C1:C9 D11 - A10:C28 D20 - A19:C27 and so on adding 9 each time and coping if there is a yes in D and pasting as an picture to the next avalible cell in worksheet PCexport.

Sub CopyIf()
Dim LastRow As Long, i As Long, erow As Long
Dim wsStr As String
Dim ws As Worksheet, wsC As Worksheet
Dim wb As Workbook, wbM As Workbook
Dim C As Range
LastRow = Worksheets("PCexport").Range("A" & Rows.Count).End(xlUp).Row


Set wb = ActiveWorkbook
Set wsC = wb.Sheets("PCrun")
erow = wsC.Cells(Rows.Count, 1).End(xlUp).Row

Worksheets("PCrun").Activate
 For i = 1 To LastRow
If wsC.Cells(2, 4).Value = "YES" Then
        erow = erow   9
        wsC.Range(wsC.Cells(1, 1), wsC.Cells(9, 3)).CopyPicture 'avoid select
        Sheets("PCexport").Range("A1").PasteSpecial
    End If
 Next i  End Sub

CodePudding user response：

Some i came up with this.

` Sub CopyIf()

Set Ask = Worksheets("PCrun").Range("$d2")
Set CP = Worksheets("PCrun").Range("a1:c9")
Set Give = Worksheets("PCexport").Range("$a1")
Worksheets("PCrun").Activate

For j = 0 To 135 Step 9
 Set CPvar = CP.Offset(j, 0)
 Set Askvar = Ask.Offset(j, 0)
 Set Givevar = Give.Offset(j, 0)


          If Askvar.Value = "YES" Then
          
        CPvar.CopyPicture
        With Sheets("PCexport").Range("A"  & Rows.Count).End(xlUp).Offset(1).PasteSpecial
        End With
    End If
Next j
End Sub`

CodePudding user response：

Try incorporating your for-step in your cell referencing Sub CopyIf() Dim LastRow As Long, i As Long, erow As Long Dim ws As Worksheet, wsC As Worksheet Dim wb As Workbook Dim C As Range LastRow = Worksheets("PCexport").Range("A" & Rows.Count).End(xlUp).Row

Set wb = ActiveWorkbook
Set wsC = wb.Sheets("PCrun")
erow = wsC.Range("A" & Rows.Count).End(xlUp).Row   1

Worksheets("PCrun").Activate
 For i = 0 To LastRow -1 Step 9
If wsC.Cells(2   i, 4).Value = "YES" Then
        wsC.Range(wsC.Cells(1   i, 1), wsC.Cells(9   i, 3)).CopyPicture 'avoid select 'not sure why you're opting for pictures
        Sheets("PCexport").Range("A" & erow).PasteSpecial
erow = erow   9 'you were filling your erow but weren't using it
    End If
 Next i  
End Sub