add rows at the end

[john_cash]

Hi everyone.
This macro appends 2 rows after the non-blank rows at the end.
can I change to increase the rows to 4?

Option Explicit


Sub aggiungi_copiaformato_new()

    On Error Resume Next
    
    Dim n As Long
    Dim x As Long
    
  
        ActiveSheet.Unprotect "987654"
       
        Dim uR As Long
        
        uR = Cells(Rows.Count, 2).End(xlUp).Row

        Range(Cells(uR - 1, 1), Cells(uR, 1)).EntireRow.Copy
        
        Application.EnableEvents = False
        
        Cells(uR + 1, 1).PasteSpecial Paste:=xlFormats
        Range("B" & Rows.Count).End(xlUp).Offset(-1).Resize(2, 16).ClearContents
        
        Application.EnableEvents = True
        
        Application.CutCopyMode = False
        
        'Application.Goto ActiveCell, scroll:=True
        
        ActiveSheet.Protect "987654"

    
End SubOption Explicit


Sub aggiungi_copiaformato_new()

    On Error Resume Next
    
    Dim n As Long
    Dim x As Long
    
  
        ActiveSheet.Unprotect "987654"
       
        Dim uR As Long
        
        uR = Cells(Rows.Count, 2).End(xlUp).Row

        Range(Cells(uR - 1, 1), Cells(uR, 1)).EntireRow.Copy
        
        Application.EnableEvents = False
        
        Cells(uR + 1, 1).PasteSpecial Paste:=xlFormats
        Range("B" & Rows.Count).End(xlUp).Offset(-1).Resize(2, 16).ClearContents
        
        Application.EnableEvents = True
        
        Application.CutCopyMode = False
        
        'Application.Goto ActiveCell, scroll:=True
        
        ActiveSheet.Protect "987654"

    
End Sub

thank you
john

 

[xenou]

this should work by expanding the range:

Change this statement:
Range(Cells(uR - 1, 1), Cells(uR, 1)).EntireRow.Copy

Amend to this instead:
Range(Cells(uR - 3, 1), Cells(uR, 1)).EntireRow.Copy

 

[john_cash]

Hi xenou
it works.
this

Range ("B" & Rows.Count) .End (xlUp) .Offset (-1) .Resize (2, 16) .ClearContents

delete the contents of the 2 lines.
Now with 4 lines it does not work.
I corrected this:

Range ("B" & Rows.Count) .End (xlUp) .Offset (-3) .Resize (2, 16) .ClearContents
Range ("B" & Rows.Count) .End (xlUp) .Offset (-2) .Resize (2, 16) .ClearContents
Range ("B" & Rows.Count) .End (xlUp) .Offset (-1) .Resize (2, 16) .ClearContents

it's right?

 

[xenou]

Okay, cool.

Probably here you could also expand the range as well:

Range ("B" & Rows.Count) .End (xlUp) .Offset (-3) .Resize (2, 16) .ClearContents
Range ("B" & Rows.Count) .End (xlUp) .Offset (-2) .Resize (2, 16) .ClearContents
Range ("B" & Rows.Count) .End (xlUp) .Offset (-1) .Resize (2, 16) .ClearContents

try instead:

Range ("B" & Rows.Count) .End (xlUp) .Offset (-3) .Resize ([B][COLOR="#FF0000"]4[/COLOR][/B], 16) .ClearContents

Note that I am guessing a bit - not tested.

 

[john_cash]

The new modification does not work cancels the previous 4 rows

 

[john_cash]

Hi xenou your change it works, my error of copy and paste.
Thank you.
john

 

[xenou]

Here is a rewrite we just use a variable for number of rows:

Sub aggiungi_copiaformato_new()

    On Error Resume Next
    
 
        ActiveSheet.Unprotect "987654"
       
        Dim uR As Long
        Dim NumberOfNewRows As Long
        
        
        uR = Cells(Rows.Count, 2).End(xlUp).Row
        NumberOfNewRows = 4

        Range(Cells(uR - (NumberOfNewRows - 1), 1), Cells(uR, 1)).EntireRow.Copy
        
        Application.EnableEvents = False
        
        Cells(uR + 1, 1).PasteSpecial Paste:=xlFormats
        
        Application.EnableEvents = True
        
        Application.CutCopyMode = False
        
        ActiveSheet.Protect "987654"

    
End Sub

However, I left out anything that involves deleting rows. Your original post said only to append blank rows so there should be nothing that needs to be deleted.

 

[john_cash]

Hi xenou amazing!
Your variable change is ok.
I added:

Range("B" & Rows.Count).End(xlUp).Offset(-(NumberOfNewRows - 1)).Resize(NumberOfNewRows, 16).ClearContents '<<< variabile

Option Explicit


Sub aggiungi_copiaformato_new()

    On Error Resume Next
    
    Dim n As Long
    Dim x As Long
   
        ActiveSheet.Unprotect "987654"
       
        Dim uR As Long
        Dim NumberOfNewRows As Long
         
        uR = Cells(Rows.Count, 2).End(xlUp).Row
        NumberOfNewRows = 12
        
        'Range(Cells(uR - 1, 1), Cells(uR, 1)).EntireRow.Copy '<<< 2 righe
        Range(Cells(uR - 3, 1), Cells(uR, 1)).EntireRow.Copy '<<< 4 righe
        Range(Cells(uR - (NumberOfNewRows - 1), 1), Cells(uR, 1)).EntireRow.Copy '<<< variabile
        
        Application.EnableEvents = False
        
        Cells(uR + 1, 1).PasteSpecial Paste:=xlFormats
        Cells(uR + 1, 1).PasteSpecial Paste:=xlFormulas
        Cells(uR + 1, 1).PasteSpecial Paste:=xlPasteValidation
        
        'Range(Cells(uR, 2), Cells(uR + 2, 12)).ClearContents
        'Range("B" & Rows.Count).End(xlUp).Offset(-1).Resize(2, 16).ClearContents '<<<2 righe
        'Range("B" & Rows.Count).End(xlUp).Offset(-3).Resize(4, 16).ClearContents '<<< 4 righe
        Range("B" & Rows.Count).End(xlUp).Offset(-(NumberOfNewRows - 1)).Resize(NumberOfNewRows, 16).ClearContents '<<< variabile
        
        Application.EnableEvents = True
        
        Application.CutCopyMode = False
        
        Application.Goto ActiveCell, scroll:=True
        
        ActiveSheet.Protect "987654"
        
    'End If
    
End Sub

thank you.
john

 

[xenou]

cool. good luck with your project.

 

[john_cash]

Hi xenou,
Your macro works, just a modification.
Now in the attached workbook it is set to 10 lines.
If I add 10 lines, the macro copies line 5 but there are only 9 lines to copy.
Is it possible to lock the macro?
I hope I explained myself

Sub aggiungi_copiaformato_new()

    On Error Resume Next
    
    Dim n As Long
    Dim x As Long
    Dim Avviso As String
    
    
    Dim rw As Range
    
'

        ActiveSheet.Unprotect "987654"
       
        Dim uR As Long
        Dim NumberOfNewRows As Long
         
        uR = Cells(Rows.Count, 2).End(xlUp).Row
        NumberOfNewRows = 10
        
        'Range(Cells(uR - 1, 1), Cells(uR, 1)).EntireRow.Copy '<<< 2 righe
        Range(Cells(uR - 3, 1), Cells(uR, 1)).EntireRow.Copy '<<< 4 righe
        Range(Cells(uR - (NumberOfNewRows - 1), 1), Cells(uR, 1)).EntireRow.Copy '<<< variabile
        
        Application.EnableEvents = False
        
        Cells(uR + 1, 1).PasteSpecial Paste:=xlFormats
        Cells(uR + 1, 1).PasteSpecial Paste:=xlFormulas
        Cells(uR + 1, 1).PasteSpecial Paste:=xlPasteValidation
        
        'Range(Cells(uR, 2), Cells(uR + 2, 12)).ClearContents
        'Range("B" & Rows.Count).End(xlUp).Offset(-1).Resize(2, 16).ClearContents '<<<2 righe
        'Range("B" & Rows.Count).End(xlUp).Offset(-3).Resize(4, 16).ClearContents '<<< 4 righe
        Range("B" & Rows.Count).End(xlUp).Offset(-(NumberOfNewRows - 1)).Resize(NumberOfNewRows, 16).ClearContents '<<< variabile
        

   
        
        Application.EnableEvents = True
        
        Application.CutCopyMode = False
        
        Application.GoTo ActiveCell, scroll:=True
        
        ActiveSheet.Protect "987654"
        
        

        
        
    'End If
    
End Sub

not how to insert an attachment.
john