Macro to copy cells with criterion

[timjohnny]

Hi all,

I hope everyone's doing well! I've come up with something I want to do and have written out what I think the code may roughly need to look like
(using bits and bobs from previous help I've gotten here on Mr Excel),
but my skills unfortunately aren't at the point yet where I know how to write it so that it works. So I hoped maybe one of you can tell me where
I went wrong, how I can write it correctly.

So I have a set of data that looks like this:

Now, I want to have a macro that copies over the three cells on the left (i.e. the comic names) to another sheet if the value of the relavant
cell to the right of them is larger than 0. Which one is the relavant cell, I specify by writing the column number into another cell, say cell A1 on Sheet2.
The macro would then move onto the next row and do the same, copying the three cells in columns A B and C over into the three cells adjacent to the ones that
the above row was previously copied into. So for the above data, that row in sheet3 (target sheet) would look like this if cell A1 in sheet2 says 4:

I imagine the code would need to look a bit like what I have below (I have to run this through 250 rows btw), would be super grateful for any suggestions how to make it work:

Sub copy_cartoons()
   Dim k As Long
   Dim j As Variant

    j = sheets("Sheet2").Range("A1").Value
  
   With Sheets("Sheet1")
      For k = 2 To 251
      if .Cells((k,j).Value > 0 Then
         .Range("A" & k).Resize(, 3).Copy Sheets("Sheet3").Cells(4, k * 3 - 1)
         Next k
    Next j
         End With
         End Sub

Thanks!

 

[Peter_SSs]

When posting vba code, please use the available code tags. I have added them for you this time. More information is in my signature block below.

I think you were pretty close. I've modified it a bit. Test with a copy of your workbook.

Sub copy_cartoons_v2()
  Dim k As Long, j As Long

  j = Sheets("Sheet2").Range("A1").Value
  With Sheets("Sheet1")
    For k = 2 To .Range("A" & Rows.Count).End(xlUp).Row
      If .Cells(k, j).Value > 0 Then .Range("A" & k).Resize(, 3).Copy Sheets("Sheet3").Cells(4, k * 3 - 1)
    Next k
  End With
End Sub

 

[Peter_SSs]

.. or perhaps it is a bit more like this that you want?

Sub copy_cartoons_v3()
  Dim k As Long, j As Long

  j = Sheets("Sheet2").Range("A1").Value
  With Sheets("Sheet1")
    For k = 2 To .Range("A" & Rows.Count).End(xlUp).Row
      If .Cells(k, j).Value > 0 Then .Range("A" & k).Resize(, 3).Copy Sheets("Sheet3").Cells(4, Columns.Count).End(xlToLeft).Offset(, 1)
    Next k
  End With
End Sub

 

[timjohnny]

Hi Peter,

Thanks a lot for your help! I'm going with the first option feels good that I got so close myself, making progress it seems ^^
Thanks again!

Best
Tim

 

[Peter_SSs]

Thanks a lot for your help!

You're welcome. Thanks for the follow-up.

feels good that I got so close myself, making progress it seems ^^

Stick with it and progress will continue.