add rows at the end

john_cash

New Member
Joined
Jul 30, 2019
Messages
23
Hi everyone.
This macro appends 2 rows after the non-blank rows at the end.
can I change to increase the rows to 4?




Code:
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
 

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
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
 
Last edited:
Upvote 0
Hi xenou
it works.
this
Code:
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:
Code:
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?
 
Upvote 0
Okay, cool.

Probably here you could also expand the range as well:

Code:
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:

Code:
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.
 
Last edited:
Upvote 0
Here is a rewrite we just use a variable for number of rows:
Code:
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.
 
Upvote 0
Hi xenou amazing!
Your variable change is ok.
I added:
Code:
Range("B" & Rows.Count).End(xlUp).Offset(-(NumberOfNewRows - 1)).Resize(NumberOfNewRows, 16).ClearContents '<<< variabile
Code:
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
 
Upvote 0
cool. good luck with your project.
 
Upvote 0
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

Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,531
Messages
6,114,172
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top