Help with speeding up the Marco/ defining dimensions

A

Ankitsahgal

New Member
Joined
Dec 19, 2015
Messages
11
Hello,
I am newbie to writing macros and still trying to get my head around dimensions. Whilst I do not understand much about them, I know that it important to define it correctly otherwise it causes the macro to run very slow.

I have written my first code and it all goes fine until ''Filter 4, from which point the code runs really slow. The filter 4 is just copying the formula from the active cell A2 and autofill it all the way down until the last data row in A.


Any advice on how to clean the code and make it run faster would be greatly appreciated.

Thanks!

Ankit

Sub AgedDebtorFinal()

Dim ws As Worksheet
Dim Rng As Range


'Copy and Rename sheet
Sheets("Aged Debtors Inv Date").Select
Sheets("Aged Debtors Inv Date").Copy before:=Sheets(3)
Sheets("Aged Debtors Inv Date (2)").Select
Sheets("Aged Debtors Inv Date (2)").Name = "Summary"

'Paste Values
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

'Unhide and delete rows

Rows("1:68").Select
Selection.Delete Shift:=xlUp

Range("C2:C5").Select
Selection.EntireRow.Delete

Columns("A:A").Select
Selection.EntireColumn.Hidden = False

'Filter and Sort

''Filter 1
Range("B1") = "FILTER"
Range("B2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]=""INSERTED GROUP"",1,""IGNORE"")"
Selection.AutoFill Destination:=Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row)
Selection.SpecialCells(xlCellTypeFormulas, 1).Select
Selection.EntireRow.Delete

''Filter 2
Range("B2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]=""INSERTED CONTINUATION"",1,""IGNORE"")"
Selection.AutoFill Destination:=Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row)
Selection.SpecialCells(xlCellTypeFormulas, 1).Select
Selection.EntireRow.Delete

''Filter 3
Range("B2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]=""INSERTED FOOTER"",TRIM(R[-1]C[1]),1)"
Selection.AutoFill Destination:=Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row)
Range("B2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

''Filter 4

Range("A2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[1]=1,1,""IGNORE"")"
Range("A2").Select
Range("A2").AutoFill Destination:=Range("A2:A" & Cells(Rows.Count, "B").End(xlDown).Row)
Selection.SpecialCells(xlCellTypeFormulas, 1).Select
Selection.EntireRow.Delete
Application.CutCopyMode = False


''Delete all the rows and columns

Columns("A").Select
Selection.EntireColumn.Delete

Columns("B:G").Select
Selection.EntireColumn.Delete

Columns("H:J").Select
Selection.EntireColumn.Delete


''Rename

Range("A1") = "Customer"
Range("G1") = "Total"

''Format

Cells.Select
With Selection.Font
.Name = "Calibri"
.Size = 12
.Bold = False
.TintAndShade = 0

End With

With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0

End With

With Selection.Borders
.LineStyle = 0

End With

End Sub
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
Sort by date Sort by votes
To make a significant chunk in processing time, remove all your .Select -> Selection from the code...

for example.

Cells.Select
Selection.Copy
can be Cells.Copy
and

Rows("1:68").Select
Selection.Delete Shift:=xlUp
can be Rows("1:68").Delete Shift:=xlUp
and

in VBA "selecting" a cell or range moves the cursor to that place. When your background code wants to whizz by at super human speed, it has to slow down for the screen to catch up with it. In general you do not need to Select any cell or range unless you want the focus to be placed on that thing at the end for the user. It is always better practice to declare your worksheets and ranges using variables and working on them that way, or at the very least just doing an action on them directly instead of selecting them (like in my examples above).

See if making those changes speeds things up to your liking.
 
Upvote 0
Ankitsahgal said:
Hello,
I am newbie to writing macros and still trying to get my head around dimensions. Whilst I do not understand much about them, I know that it important to define it correctly otherwise it causes the macro to run very slow.

I have written my first code and it all goes fine until ''Filter 4, from which point the code runs really slow. The filter 4 is just copying the formula from the active cell A2 and autofill it all the way down until the last data row in A.


Any advice on how to clean the code and make it run faster would be greatly appreciated.

Thanks!

Ankit

Code: 
Sub AgedDebtorFinal()

Dim ws As Worksheet
Dim Rng As Range


'Copy and Rename sheet
    Sheets("Aged Debtors Inv Date").Select
    Sheets("Aged Debtors Inv Date").Copy before:=Sheets(3)
    Sheets("Aged Debtors Inv Date (2)").Select
    Sheets("Aged Debtors Inv Date (2)").Name = "Summary"
        
 'Paste Values
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
        
'Unhide and delete rows

    Rows("1:68").Select
    Selection.Delete Shift:=xlUp
  
    Range("C2:C5").Select
    Selection.EntireRow.Delete
    
    Columns("A:A").Select
    Selection.EntireColumn.Hidden = False
    
 'Filter and Sort
     
     ''Filter 1
    Range("B1") = "FILTER"
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-1]=""INSERTED GROUP"",1,""IGNORE"")"
    Selection.AutoFill Destination:=Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row)
    Selection.SpecialCells(xlCellTypeFormulas, 1).Select
    Selection.EntireRow.Delete
     
      ''Filter 2
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-1]=""INSERTED CONTINUATION"",1,""IGNORE"")"
    Selection.AutoFill Destination:=Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row)
    Selection.SpecialCells(xlCellTypeFormulas, 1).Select
    Selection.EntireRow.Delete
    
      ''Filter 3
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-1]=""INSERTED FOOTER"",TRIM(R[-1]C[1]),1)"
    Selection.AutoFill Destination:=Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row)
    Range("B2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
           
   [COLOR=#ff0000]    ''Filter 4[/COLOR]
      
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[1]=1,1,""IGNORE"")"
    Range("A2").Select
    Range("A2").AutoFill Destination:=Range("A2:A" & Cells(Rows.Count, "B").End(xlDown).Row)
    Selection.SpecialCells(xlCellTypeFormulas, 1).Select
    Selection.EntireRow.Delete
    Application.CutCopyMode = False
    
       
     ''Delete all the rows and columns
       
    Columns("A").Select
    Selection.EntireColumn.Delete
    
    Columns("B:G").Select
    Selection.EntireColumn.Delete
    
    Columns("H:J").Select
    Selection.EntireColumn.Delete
    
    
    ''Rename
    
    Range("A1") = "Customer"
    Range("G1") = "Total"
    
    ''Format
    
    Cells.Select
    With Selection.Font
        .Name = "Calibri"
        .Size = 12
        .Bold = False
        .TintAndShade = 0
   
    End With
    
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
                  
    End With

    With Selection.Borders
        .LineStyle = 0
    
    End With
        
End Sub
Click to expand...

Let's have a look....
 
Upvote 0
Try this out on a C O P Y O F O R I G I N A L

***There is no undo feature from VBA code mistakes***
Code: 
Option Explicit

Sub AgedDebtorFinal()

Dim ws As Worksheet, Rng As Range

Rem stops updating to speed up the code
    With Application
        .ScreenUpdating = False
    
    'Copy and Rename sheet
        'Sheets("Aged Debtors Inv Date").Select
    Rem If you add the sheet after all the others you can never get a naming error _
        using this method.
        Sheets("Aged Debtors Inv Date").Copy after:=Sheets.Count
        Sheets(Sheets.Count).Name = "Summary"
    Rem Try the following line
        'Sheets("Summary").Move before:=Sheets("Aged Debtors Inv Date")
    
     'Paste Values
        Cells.Copy Cells
        'Selection.PasteSpecial Paste:=xlPasteValues
        'Application.CutCopyMode = False
            
    'Unhide and delete rows
    
        Rows("1:68").Delete Shift:=xlUp
      
        [C2:C5].EntireRow.Delete
        
        Columns("A:A").EntireColumn.Hidden = False
        
     'Filter and Sort
        [B1] = "FILTER"
        Call Filter1
        Call Filter2
        Call Filter3
        Call Filter4
           
         ''Delete all the rows and columns
           
        Columns("A,B:G,H:J").EntireColumn.Delete
        
        ''Rename
        
        [A1] = "Customer"
        [G1] = "Total"
        
        ''Format
        
        With Cells.CurrentRegion
            With .Font
                .Name = "Calibri"
                .Size = 12
                .Bold = False
                .TintAndShade = 0
            End With
    
            With .Interior
                .Pattern = xlNone
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
            .Borders.LineStyle = 0
        End With
Rem resets updating sequence to speed up the code
        .ScreenUpdating = False
    End With
End Sub
Private Sub Filter1()
     ''Filter 1
    With Range("B2")
        .Value = "=IF(RC[-1]=""INSERTED GROUP"",1,""IGNORE"")"
        .AutoFill Destination:=Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row)
        .SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
    End With

End Sub
Private Sub Filter2()
      ''Filter 2
    With Range("B2")
        .Value = "=IF(RC[-1]=""INSERTED CONTINUATION"",1,""IGNORE"")"
        .AutoFill Destination:=Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row)
        .SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
    End With

End Sub
Private Sub Filter3()
      ''Filter 3
    With Range("B2")
        .FormulaR1C1 = "=IF(RC[-1]=""INSERTED FOOTER"",TRIM(R[-1]C[1]),1)"
        .AutoFill Destination:=Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row)
        .End(xlDown).Copy [B2]
    End With
End Sub

Private Sub Filter4()
       ''Filter 4
    [A2].Value = "=IF(RC[1]=1,1,""IGNORE"")"
    [A2].AutoFill Destination:=Range("A2:A" & Cells(Rows.Count, "B").End(xlDown).Row)
    [A2].SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
End Sub
 
Last edited:
Upvote 0
Hi,

Don't know is this what you want? :

Code: 
Sub macro()




Dim x As Long
Dim customer As String
Dim rng As Range
Dim last_row As Long




Worksheets.Add(before:=Sheets(3)).Name = "Summary"
With Sheets("Summary")
    .Range("A1").Value = "Customer"
    .Range("B1:F1").Value = Sheets("Aged Debtors Inv Date").Range("I69:M69").Value
    .Range("G1").Value = "Total"
End With


With Sheets("Aged Debtors Inv Date")
    For x = 74 To .Range("A" & .Rows.Count).End(xlUp).Row
        If .Range("A" & x).Value = "INSERTED FOOTER" Then
           customer = .Range("C" & x - 1).Value
           Set rng = .Range("I" & x & ":N" & x)
           With Sheets("Summary")
                last_row = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                .Range("A" & last_row).Value = customer
                .Range("B" & last_row & ":G" & last_row).Value = rng.Value
           End With
        End If
    Next
End With


With Sheets("Summary").Cells
    .Font.Name = "Calibri"
    .Font.Size = 12
End With


End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question
Variable Rows, Help Speeding Up
Replies
4
Views
359
kevin9999
K
T
  • Question
ActiveSheet. Paste error
Replies
1
Views
104
RoryA
RoryA
P
  • Question
Help with Vba Code
Replies
3
Views
214
Coyotex3
C
C
  • Question
How to get my macro to stop at the last recognized line
Replies
6
Views
301
Coco1
C
L
  • Solved
VBA remove leading zeros
2
Replies
14
Views
1K
Joe4
Joe4

Forum statistics

Threads
1,216,107
Messages
6,128,866
Members
449,475
Latest member
Parik11

Share this page

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