VBA - Speed up a formatting macro

S

spencerp237

New Member
Joined
Feb 24, 2017
Messages
26
This is the macro I have to format a set of data, delete certain rows based on certain criteria, and then refresh a pivot table that is using it as a data source. It all runs fine for me, but I am looking for ways to speed it up. Pretty much the entire formatting part of the macro was done by recording as well.

Code: 
Sub formatExport()

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.DisplayAlerts = False
ActiveSheet.DisplayPageBreaks = False


Dim lastRow As Long


lastRow = Sheets("CustomReport").Cells(Rows.count, 1).End(xlUp).Row


'Insert new columns to adjust for text to columns
Sheets("CustomReport").Select
Columns("E:E").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("D:D").Select
Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :="_", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
Selection.NumberFormat = "General"
Range("G2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
    "=IF(AND(RC[-2]<>"""",RC[-1]<>""""),RC[-2]&""_""&RC[-1],IF(RC[-2]<>"""",RC[-2],""""))"
Range("G2").Select
Selection.AutoFill Destination:=Range("G2:G" & lastRow)
Range("G2:G" & lastRow).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Columns("E:F").Select
Application.CutCopyMode = False
Selection.delete Shift:=xlToLeft
Range("E1").Select
ActiveCell.FormulaR1C1 = "Sleeve"
Range("D1").Select
Selection.Copy
Range("E1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
    
'Create MS Count column
Sheets("CustomReport").Select
Columns("H:H").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("H2").Select
ActiveCell.FormulaR1C1 = "=RC[-1]&COUNTIF(R2C7:RC7,RC7)"
Range("H2").Select
Selection.AutoFill Destination:=Range("H2:H" & lastRow)
Range("H2:H" & lastRow).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("H1").Select
ActiveCell.FormulaR1C1 = "Mgmt Style Count"
Range("D1").Select
Selection.Copy
Range("H1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Range("H2:H" & lastRow).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
    
'Use Text To Columns to set formatting
Sheets("CustomReport").Select
Columns("V:V").Select
Selection.TextToColumns Destination:=Range("V1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
    :=Array(1, 1), TrailingMinusNumbers:=True
    
'Concatenated MS & BD
Sheets("CustomReport").Select
Range("W2").Select
ActiveCell.FormulaR1C1 = "=RC[-16]&RC[-8]"
Range("W2").Select
Selection.AutoFill Destination:=Range("W2:W" & lastRow)
Range("W2:W" & lastRow).Select
Range("W1").Select
ActiveCell.FormulaR1C1 = "MgmtStyleBD"
Range("V1").Select
Selection.Copy
Range("W1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Range("W2:W" & lastRow).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
Columns("W:W").EntireColumn.AutoFit
    
'Excluded BD Check 1
Range("X2").Select
ActiveCell.FormulaR1C1 = _
    "=IFERROR(INDEX('Excluded BD as Manager'!R1C3:R10C3, MATCH(RC[-9]&INDEX(Database_Managers!C[-23]:C[-21],MATCH(INDEX(Database_Strategy!C[-21]:C[-19], MATCH(RC[-17],Database_Strategy!C[-19],0),1),Database_Managers!C[-23],0),2),'Excluded BD as Manager'!R1C3:R10C3,0),1),""Include"")"
Range("X2").Select
Selection.AutoFill Destination:=Range("X2:X" & lastRow)
Range("X2:X" & lastRow).Select
Range("X1").Select
ActiveCell.FormulaR1C1 = "Manager Exclusion"
Range("X2:X" & lastRow).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Columns("X:X").EntireColumn.AutoFit
Columns("X:X").Select
    
'Excluded BD Check 2
Range("Y2").Select
ActiveCell.FormulaR1C1 = _
    "=IF(ISERROR(VLOOKUP(RC[-10],'Excluded BD'!C[-24],1,FALSE)) = TRUE, ""Include"", ""Exclude"")"
Range("Y2").Select
Selection.AutoFill Destination:=Range("Y2:Y" & lastRow)
Range("Y2:Y" & lastRow).Select
Range("Y1").Select
ActiveCell.FormulaR1C1 = "Include/Exclude"
Range("W1").Select
Selection.Copy
Range("Y1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Range("Y2:Y" & lastRow).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
Columns("Y:Y").EntireColumn.AutoFit


'Pivot Table Summary Workaround
Sheets("CustomReport").Select
Range("Z2").Select
ActiveCell.FormulaR1C1 = "TOTAL:"
Range("Z2").Select
Selection.AutoFill Destination:=Range("Z2:Z" & lastRow)
Range("Z1").Select
ActiveCell.FormulaR1C1 = " "
Range("Y1").Select
Selection.Copy
Range("Z1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Range("Z2:Y" & lastRow).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Application.CutCopyMode = False
Columns("Z:Z").EntireColumn.AutoFit


'Make sure Date cells updated on Bill sheet
Sheets("Bill").Select
Range("P4").Select
ActiveCell.FormulaR1C1 = _
    "=CustomReport!R[-2]C[4]"
        
Sheets("Bill").Select
Range("P6").Select
ActiveCell.FormulaR1C1 = _
    "=COUNTIF(CustomReport!C7:C7, Bill!R[-1]C)"
    
'Delete Rows
    Call deleteRows
    
'Refresh Pivot Table
    Call refreshBDSummary


Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.DisplayAlerts = True
ActiveSheet.DisplayPageBreaks = True
    
End Sub


Sub deleteRows()
'If one of these 6 criteria is false, delete
'1. Value > 200
'2. Not on the Excluded BD list
'3. Mgmt Style is in the Database_Strategy list
'4. Account is sleeved out (looks for a _ )
'5. Account number does not contain "XX"
'6. Not on the Excluded BD As Manager list


Dim lastColumn As Long
Dim usedRows As Long
Dim Rng As Range
    
Application.ScreenUpdating = False


Sheets("CustomReport").Select
lastColumn = Cells(1, Columns.count).End(xlToLeft).Offset(, 1).Column
usedRows = Range("A" & Rows.count).End(xlUp).Row
    
Range(Cells(2, lastColumn), Cells(usedRows, lastColumn)).Formula = "=IF(OR(IFERROR(FIND(""XX"",D2)) = FALSE,V2<200,E2="""",X2<>""Include"",Y2=""Exclude"",MATCH(G2,Database_Strategy!E:E,0)< 1,COUNTIF('Excluded BD'!A:A,O2)>0),""Delete"",""Keep"")"
Set Rng = Range(Cells(2, 1), Cells(usedRows, lastColumn))


With Columns(lastColumn)
    .AutoFilter
    .AutoFilter field:=1, Criteria1:="<>Keep"
    On Error Resume Next
    Rng.SpecialCells(xlCellTypeVisible).EntireRow.delete
    On Error GoTo 0
    .AutoFilter
End With


Columns(lastColumn).delete
    
Application.ScreenUpdating = True
    
End Sub


Sub refreshBDSummary()


'SOURCE: www.TheSpreadsheetGuru.com/The-Code-Vault


Dim Data_sht As Worksheet
Dim Pivot_sht As Worksheet
Dim PivotName As String
Dim NewRange As Range


'Set Variables Equal to Data Sheet and Pivot Sheet
Set Data_sht = ThisWorkbook.Worksheets("CustomReport")
Set Pivot_sht = ThisWorkbook.Worksheets("BD Summary")


'Enter in Pivot Table Name
PivotName = "BDSummary"


'Dynamically Retrieve Range Address of Data
With Sheets("CustomReport")
    Set NewRange = .Range("A1:Z" & .Cells(Rows.count, 1).End(xlUp).Row)
End With
    
'Change Pivot Table Data Source Range Address
Pivot_sht.PivotTables(PivotName).ChangePivotCache _
    ThisWorkbook.PivotCaches.Create( _
    SourceType:=xlDatabase, _
    SourceData:=NewRange)
      
'Ensure Pivot Table is Refreshed
Pivot_sht.PivotTables(PivotName).RefreshTable


'Complete Message
MsgBox PivotName & "'s data source range has been successfully updated!"


End Sub
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Sort by date Sort by votes
You must log in or register to reply here.

Similar threads

D
  • Solved
Insert formula in last column macro
2
Replies
13
Views
215
MARK858
MARK858
Dazzawm
  • Solved
Change Range To Recorded Macro
Replies
3
Views
191
Alex Blakenburg
A
willow1985
  • Solved
VBA Run-time error 91 - Object variable or With block variable not set when trying to refresh data/Sleep
Replies
4
Views
400
willow1985
willow1985
S
  • Solved
VBA autofilling code
Replies
6
Views
603
Peter_SSs
Peter_SSs
Sean15
  • Question Question
Could you help improve recorded macro
2
Replies
13
Views
474
Sean15
Sean15

Forum statistics

Threads
1,224,823
Messages
6,181,177
Members
453,021
Latest member
Justyna P

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