Macro to copy and move

[Abvlecxe]

Hi,

I need a macro that works out the number of rows which has data in column C, when known it copies the data from each row in the range to another sheet.

However, it’s not just a straight forward copy a row to another sheet, the code needs to select obe cell at a time as each cell is going to a different place in the other sheet,

My current range of data is in C11:G24 which is 14 rows, but this should not be fixed and can increase by rows.

So, starting in cell sheet1 cell C11 the code should copy this data to another sheet2 cell A5, once done the code moves to the next cell on the right

Example:
'Copy sheet1 cell "C11" to sheet2 cell "A5"
'Copy sheet1 cell "D11" to sheet2 cell "E5"
'Copy sheet1 cell "E11" to sheet2 cell "D5"
'Copy sheet1 cell "f11" to sheet2 cell "N5"
'Copy sheet1 cell "g11" to sheet2 cell "O5"

'Then the code moves down to the next row so:
'Copy sheet1 cell "C12" to sheet2 cell "A6"
'Copy sheet1 cell "D12" to sheet2 cell "E6"
'Copy sheet1 cell "E12" to sheet2 cell "D6"
'Copy sheet1 cell "F12" to sheet2 cell "N6"
'Copy sheet1 cell "G12" to sheet2 cell "O6"

It keeps on going until it comes to the last row in column C with data to copy.
Thanks in advance!

 

[Abvlecxe]

Perfect, that worked a treat! Thank you very much

Try:

Sub CopyMove()
    
    Dim x           As Long
    Dim y           As Long
    Dim arr()       As Variant
    Dim arrMap()    As Variant
    Const DELIM     As String = "|"
    
    arrMap = Array(1, 5, 4, 14, 15)
    
    With Sheets("Sheet1")
        x = Application.Max(12, .Cells(.Rows.Count, 3).End(xlUp).Row) - 10
        arr = .Cells(11, 3).Resize(x, 5).Value
    End With
    
    Application.ScreenUpdating = False
        
    With Sheets("Sheet2")
        For x = LBound(arr, 1) To UBound(arr, 1)
            For y = LBound(arrMap) To UBound(arrMap)
                .Cells(x + 4, arrMap(y)).Value = arr(x, y + 1)
            Next y
        Next x
    End With
    
    Application.ScreenUpdating = True
    
    Erase arr
    Erase arrMap
    
End Sub

 

[JackDanIce]

You're welcome

 

[Abvlecxe]

I've been looking at your code working out what it does, I can figure out what it does down until here:

Application.ScreenUpdating = False

With Sheets("Journal Template")
For x = LBound(arr, 1) To UBound(arr, 1)
For y = LBound(arrMap) To UBound(arrMap)
.Cells(x + 4, arrMap).Value = arr(x, y + 1)
Next y
Next x
End With

Application.ScreenUpdating = True

If it's not too much trouble would you mind giving a brief explanation of what the code does here please?

Ta

You're welcome