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!

 

[JackDanIce]

Try:

Sub CopyMove()
    
    Dim x           As Long
    Dim y           As Long
    Dim i           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
    
    For x = LBound(arr, 1) To UBound(arr, 1)
        For y = LBound(arrMap) To UBound(arrMap)
            With Sheets("Sheet2")
                i = Application.Max(5, .Cells(.Rows.Count, 1).End(xlUp).Row)
                .Cells(i, arrMap(y)).Value = arr(x, y + 1)
            End With
        Next y
    Next x
    
    Erase arr
    Erase arrMap
    
End Sub

 

[Abvlecxe]

Thanks for the reply JackDanIce.

The macro you provided just seems to copy the last row of data which currently is row G, when the macro works out the number of rows does it then start the copy from cell C11 which is the start of my range and loop through the copy for the number of rows it has calculated?

Try:

Sub CopyMove()
    
    Dim x           As Long
    Dim y           As Long
    Dim i           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
    
    For x = LBound(arr, 1) To UBound(arr, 1)
        For y = LBound(arrMap) To UBound(arrMap)
            With Sheets("Sheet2")
                i = Application.Max(5, .Cells(.Rows.Count, 1).End(xlUp).Row)
                .Cells(i, arrMap(y)).Value = arr(x, y + 1)
            End With
        Next y
    Next x
    
    Erase arr
    Erase arrMap
    
End Sub

 

[JackDanIce]

Had a line of code in the wrong place so was writing data into the same row each time on Sheet2. Try:

Sub CopyMove()
    
    Dim x           As Long
    Dim y           As Long
    Dim LR           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)
            LR = Application.Max(5, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
            For y = LBound(arrMap) To UBound(arrMap)
                .Cells(LR, arrMap(y)).Value = arr(x, y + 1)
            Next y
        Next x
    End With
    
    Application.ScreenUpdating = True
    
    Erase arr
    Erase arrMap
    
End Sub

 

[Abvlecxe]

That 99% works, apart from the data is copied into sheet2 row 15, it should be copied into row 5 or the first available blank row

Thanks for your help

Had a line of code in the wrong place so was writing data into the same row each time on Sheet2. Try:

Sub CopyMove()
    
    Dim x           As Long
    Dim y           As Long
    Dim LR           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)
            LR = Application.Max(5, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
            For y = LBound(arrMap) To UBound(arrMap)
                .Cells(LR, arrMap(y)).Value = arr(x, y + 1)
            Next y
        Next x
    End With
    
    Application.ScreenUpdating = True
    
    Erase arr
    Erase arrMap
    
End Sub

 

[JackDanIce]

It seems the code is finding something in cell A14 so it's starting in A15 of Sheet2...

 

[Abvlecxe]

Actually i don't think it is, it's inserting the data at the bottom of the table. Maybe i should have said earlier but the data is being copied into a table and the code is starting from the bottom of the table. So i just deleted all the rows of the table apart from row 5 and the code inserts the data from row 6. Does macros not see a blank table range as empty?

 

[JackDanIce]

I guess not then, this line here:

LR = Application.Max(5, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)

Finds the maximum between 5 and the last used row + 1 (in column 1 or A) in Sheet2
Is the bottom of the table on row 14 of Sheet2?

 

[Abvlecxe]

it was when i first ran the macro and the macro put the data into row 15. When i delete some of the rows of the table to say row 6 so there is only one row of the table left the macro puts the data into row 6 so for whatever reason the macro doesn't see a table row as being an empty line.

Any ideas or would it be easier to state copy the data to row 5 onwards as this will always be the first row i want the data copied to?

Thanks

I guess not then, this line here:

LR = Application.Max(5, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)

Finds the maximum between 5 and the last used row + 1 (in column 1 or A) in Sheet2
Is the bottom of the table on row 14 of Sheet2?

 

[JackDanIce]

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