VBA to copy the column and paste as new row with merged cells-CodePudding

I am trying to copy a column value and paste as a new row after each row as a merged cell. I have started my step towards this and managed to add a blank row after each row on specified sheet with range but need further on copying the column cell value and paste into each row.

Any help would be appreciated.

Thanks

 Sub Macro1()
 Dim LastRow, RowNumber As Long
 Dim ws As Worksheet
 'FOLLOWING WORKS WITH RANGED AND SPECIFIED SPREADSHEET
 Set ws = ThisWorkbook.Worksheets("Asset")
With ws
 LastRow = Cells(Rows.Count, "A").End(xlUp).Row
      For RowNumber = LastRow To 11 Step -1 'FROM WHAT ROW TO START THE INSERT ROW BLANK
    .Rows(RowNumber).Insert
Next RowNumber
End With
End Sub

CodePudding user response：

Recorded macro

Sub Macro1()
'
    Rows("4:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("D3").Select
    Selection.Cut
    Range("A4").Select
    Selection.Paste
    Range("A4:C4").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
End Sub

So cutting out what is unnecessary and making it useable in a loop we get:

Sub Macro2()
    Dim LastRow As Long, RowNumber As Long
    
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Asset")
    Dim FirstRow As Long: FirstRow = 6

    With ws
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For RowNumber = LastRow To FirstRow Step -1
            .Rows(RowNumber   1).Insert Shift:=xlDown              'Want inserted row below
            .Cells(RowNumber, 4).Cut Destination:=.Range("A" & RowNumber   1)
            With .Range(.Cells(RowNumber   1, 1), .Cells(RowNumber   1, 3))
                .Merge
                .HorizontalAlignment = xlCenter
            End With
        Next RowNumber
    End With
    
End Sub

CodePudding user response：

I commented in code what steps i took to make the sample work correctly.

Sub Macro1()
 Dim LastRow, RowNumber As Long
 Dim ws As Worksheet
 Dim valueToCopy As String


 
 'FOLLOWING WORKS WITH RANGED AND SPECIFIED SPREADSHEET
  Set ws = ThisWorkbook.Worksheets("Asset")
 
 Range("A1").Select ' select the first cell in the worksheet.


'get the value from the first row. in column A
LastRow = Cells(Rows.Count, "A").End(xlUp).Row

For i = 2 To LastRow   2

'get the value to copy to the next row.
valueToCopy = Rows(i).Cells(1, 4).Value

'insert a row below the current row
Rows(i   1).Select

Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

Rows(i   1).Cells(1, 1).Select
Rows(i   1).Cells(1, 1).Value = valueToCopy
Range(ActiveSheet.Cells(ActiveCell.Row, 1), ActiveSheet.Cells(ActiveCell.Row, 4)).Select



With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
i = i   1

Next i

End Sub

I started with a spreadsheet like this.

end result looks like this .