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

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Sort by date Sort by votes
You must log in or register to reply here.

Similar threads

P
  • Question
Help with Vba Code
Replies
3
Views
160
Coyotex3
C
L
  • Question
Variable Rows, Help Speeding Up
Replies
4
Views
318
kevin9999
K
P
  • Solved
Counter in For Each loop
Replies
2
Views
197
Possum17
P
C
  • Question
Loop/Repeat Macro
2
Replies
11
Views
370
kvsrinivasamurthy
K
L
  • Solved
VBA remove leading zeros
2
Replies
14
Views
970
Joe4
Joe4

Forum statistics

Threads
1,214,979
Messages
6,122,557
Members
449,088
Latest member
davidcom

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