Macro to copy cells with criterion

timjohnny

New Member
Joined
Aug 23, 2021
Messages
17
Office Version
  1. 2019
Platform
  1. Windows
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:

1630402011509.png


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:

1630402088587.png



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:

VBA Code:
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!
 
Last edited by a moderator:

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
51,725
Office Version
  1. 365
Platform
  1. Windows
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.

VBA Code:
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
 
Solution

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
51,725
Office Version
  1. 365
Platform
  1. Windows
.. or perhaps it is a bit more like this that you want?

VBA Code:
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

New Member
Joined
Aug 23, 2021
Messages
17
Office Version
  1. 2019
Platform
  1. Windows
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
 

Forum statistics

Threads
1,147,635
Messages
5,742,250
Members
423,717
Latest member
rubthenut

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top