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

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
Sort by date Sort by votes
You must log in or register to reply here.

Similar threads

Dazzawm
  • Solved
Change Range To Recorded Macro
Replies
3
Views
152
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
280
willow1985
willow1985
S
  • Question Question
Dynamic Address by VBA
Replies
8
Views
152
MikeVol
MikeVol
S
  • Solved
VBA autofilling code
Replies
6
Views
485
Peter_SSs
Peter_SSs
Sean15
  • Question Question
Could you help improve recorded macro
2
Replies
13
Views
444
Sean15
Sean15

Forum statistics

Threads
1,223,903
Messages
6,175,289
Members
452,631
Latest member
a_potato

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