Macro for conditional copy range

[Khardin]

Hello,

First let me thank you for your time assisting me with this. I have extensively researched the forums and tried to implement/modify various suggestions but to no avail.

I am trying to create a macro that will copy and paste a range of cells based on the condition of another cell.
I know the logic I am trying to use, just not how to implement it:

The logic is:
If Cell D2=1, copy range(E2:I2) and paste in range(K3:P3)
If Cell D2=0, copy range(E2:I2) and paste in range(Q3:U3)
continue to iterate through (ie: D3=1, copy range (E3:I3) and paste in range(K4:P4))
Stop at first empty cell in D

Column D (starting at row 2) will always contain either a 0 or a 1 and I am always looking to copy the same number of cells
The data in range E:I is all numeric
Range K:P and Q:U are all blank starting from row 3

Thank you again for your assistance!

 

[Trebor76]

Hi Khardin,

Try this:

Dim rngCell As Range
    
    Application.ScreenUpdating = False
    
    For Each rngCell In Range("D2", Range("D" & Rows.Count).End(xlUp))
        Select Case rngCell.Value
            Case Is = 0
                Range("E" & rngCell.Row & ":I" & rngCell.Row).Copy Destination:=Range("Q" & rngCell.Row + 1 & ":U" & rngCell.Row + 1)
            Case Is = 1
                Range("E" & rngCell.Row & ":I" & rngCell.Row).Copy Destination:=Range("K" & rngCell.Row + 1 & ":P" & rngCell.Row + 1)
        End Select
    Next rngCell
    
    Application.ScreenUpdating = True
    
    MsgBox "Process complete.", vbInformation

Regards,

Robert

 

[Khardin]

Hi Khardin,

Try this:

Dim rngCell As Range
    
    Application.ScreenUpdating = False
    
    For Each rngCell In Range("D2", Range("D" & Rows.Count).End(xlUp))
        Select Case rngCell.Value
            Case Is = 0
                Range("E" & rngCell.Row & ":I" & rngCell.Row).Copy Destination:=Range("Q" & rngCell.Row + 1 & ":U" & rngCell.Row + 1)
            Case Is = 1
                Range("E" & rngCell.Row & ":I" & rngCell.Row).Copy Destination:=Range("K" & rngCell.Row + 1 & ":P" & rngCell.Row + 1)
        End Select
    Next rngCell
    
    Application.ScreenUpdating = True
    
    MsgBox "Process complete.", vbInformation

Regards,

Robert

Thanks Robert! This works perfectly

 

[Trebor76]

Thanks for letting us know and you're welcome