VBA code for copy/paste a variable amount of rows and adding a certain value in one specific column

[Robbans]

Hi there,

I´m new in the VBA world and I´m trying to learn how to use it in an efficient way and at the same time develop a feature in my spreadsheet, see bullet 4 below:

#1 Copy an activated row, insert a new row below and paste the formula in column(not formula) there (Solved)
#2 Highlight it with another color (Solved)
#3 Insert a choosen value in column U (via inputbox) ( Solved)
#4 Be able to do this for multiple selected rows(amount of rows varying from time to time). Selection is sometime clustered but sometimes there are other rows in betweeen the selected rows.

This is my code

Private Sub CommandButton9_Click()
' add_row_62 Macro
'
 Dim rng As Range
    Set rng = Activecell.Range("A1") ' <~~  Change this
    
    lRsp = MsgBox("Add row below this row " & lRow & " and fill in code 62?", _
            vbQuestion + vbYesNo, "Kritiskt moment")
    If lRsp <> vbYes Then Exit Sub


        ' Insert a row below the current one
        rng.Offset(1).Insert


        ' Copy the current row and paste it into the row we just inserted
        rng.EntireRow.Copy rng.Offset(0)
        rng.Offset(0).EntireRow.Copy
        rng.Offset(1).PasteSpecial xlPasteFormulas
        rng.Offset(0).Copy
        rng.Offset(1).PasteSpecial xlPasteValues
        
        Set rng = rng.Offset(1)
    
     Activecell.Range("A1:W1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With
    Selection.End(xlToLeft).Select
    Activecell.Offset(0, 22).Range("A1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With
    Activecell.Offset(0, 0).Range("A1").Select
    Activecell.FormulaR1C1 = "OB"
    Activecell.Offset(0, -5).Range("A1").Select
    Activecell.FormulaR1C1 = "62"
    Activecell.Offset(0, 3).Range("A1").Select
    Selection.ClearContents
    
    Me.Hide
    QTYInput = InputBox("Hours to be filled")
    Activecell.Value = QTYInput
    Activecell.Select
    
    With Selection
    .NumberFormat = "General"
    .Value = .Value
 


'
End With
End Sub

 

[DanteAmor]

Test the next macro

Private Sub CommandButton9_Click()
    Dim rng As Range
    Dim fila As Range
    Set rng = Selection
    ini = rng.Cells(1, 1).Row
    fin = rng.Rows.Count + ini - 1
    QTYInput = InputBox("Hours to be filled")
    For i = fin To ini Step -1
        Set fila = Rows(i)
        fila.Offset(1).Insert
        fila.Offset(0).EntireRow.Copy
        fila.Offset(1).PasteSpecial xlPasteFormulas
        fila.Offset(1).PasteSpecial xlPasteValues
        With fila.Range("A1:W1").Offset(1).Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent2
            .TintAndShade = 0.399975585192419
            .PatternTintAndShade = 0
        End With
        Cells(fila.Row + 1, "R").Value = 62
        Cells(fila.Row + 1, "U").Value = QTYInput
        Cells(fila.Row + 1, "U").NumberFormat = "General"
        Cells(fila.Row + 1, "W").Value = "OB"
    Next
    rng.Select
    '
    Application.CutCopyMode = False
End Sub

 

[Robbans]

Thanks DanetAmor, it works like a charm! Highly appreciated and most welcome

As this code is set up it works according to my specification for rows that are in a bundle for example for rows 1,2,3,4, Is it possible to adjust the code to work with random rows, for example row 1,5,55 and perform the same features?

Grateful for all help!

BR
Robert

 

[DanteAmor]

Of course, here the updated macro

Private Sub CommandButton9_Click()
    Application.ScreenUpdating = False
    Dim rng As Range
    Dim fila As Range
    Dim filas()
    Dim i As Double, n As Double
    '
    Set rng = Selection.Rows
    QTYInput = InputBox("Hours to be filled")
    n = 0
    For Each r In rng
        ReDim Preserve filas(n)
        filas(n) = r.Row
        n = n + 1
    Next
    For i = UBound(filas) To LBound(filas) Step -1
        Set fila = Rows(filas(i))
        fila.Offset(1).Insert
        fila.Offset(0).EntireRow.Copy
        fila.Offset(1).PasteSpecial xlPasteFormulas
        fila.Offset(1).PasteSpecial xlPasteValues
        With fila.Range("A1:W1").Offset(1).Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent2
            .TintAndShade = 0.399975585192419
            .PatternTintAndShade = 0
        End With
        Cells(fila.Row + 1, "R").Value = 62
        Cells(fila.Row + 1, "U").Value = QTYInput
        Cells(fila.Row + 1, "U").NumberFormat = "General"
        Cells(fila.Row + 1, "W").Value = "OB"
    Next
    rng.Select
    '
    Application.CutCopyMode = False
End Sub

I'm glad to help you :wink:

 

[Robbans]

Great stuff DanteAmor, nice coding.

Have a great day!

BR

Robert

 

[DanteAmor]

Great stuff DanteAmor, nice coding.

Have a great day!

BR

Robert

Have a great day too!