how can i optimize the VBA code for formatting? - excel

Question

I have below code which will help me to do some formatting. but i want increase the efficiency of the code by reducing the time. Below are the formatting steps which macro will be doing.
Convert "Q" and "S" column" to number format.
Replicate the "I" column to new column by inserting column next to it.
Cut the Column "AD" and paste to column "O".
Remove columns ("A:A,AD:AG")
Replace "#" with null and "OUT" with P input value in "AC" column.
Round the "Q" and "S" column numbers to 2 decimal.
Change the sign of values in column Q by multiplying -1(*-1)
Filter on "Q" column with "0" and filter on "S" column with "0". Then
remove those rows with "Q" and "S" is Zero.
Filter 0 on Q column, Clear only visible cells of "Q" and "R" Columns.
Filter 0 on "S" column, Clear only visible cells of "S" and "T" Columns.
Copy the headers (ThisWorkbook.Sheets("Tool").Range("A20:AC20").Copy) and
paste to the A1 of file formatted.
Remove all columns and rows which doesn’t have data apart from used
range.
Currently macro working fine but taking some time.As i am new to VBA not sure how to optimize the code. Hence i here looking for help from experts. Thanks in advance.
Below is the code
Sub Ananplan_to_BPM()
Dim LastRow As Long
Dim Lastcol As Long
Dim P As String
'Display a Dialog Box that allows to select a single file.
'The path for the file picked will be stored in fullpath variable
With Application.FileDialog(msoFileDialogFilePicker)
'Makes sure the user can select only one file
.AllowMultiSelect = True
'Filter to just the following types of files to narrow down selection options
'.Filters.Add "All Files", "*.xlsx; *.xlsm; *.xls; *.xlsb; *.csv"
'Show the dialog box
.Show
'Store in fullpath variable
fullpath = .SelectedItems.Item(1)
End With
'It's a good idea to still check if the file type selected is accurate.
'Quit the procedure if the user didn't select the type of file we need.
If InStr(fullpath, ".xls") = 0 Then
If InStr(fullpath, ".csv") = 0 Then
Exit Sub
End If
End If
'Open the file selected by the user
Workbooks.Open fullpath
P = InputBox("Please Enter the Version")
Application.ScreenUpdating = False
With ActiveWorkbook
Columns(17).NumberFormat = "0"
Columns(19).NumberFormat = "0"
LastRow = Cells(Rows.Count, 2).End(xlUp).Row
Lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
Columns("I").Copy
Columns("I").Insert Shift:=xlToRight
'Range("AE2").Value = P
'Range("AE2", "AE" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Columns("AE").Copy
Columns("P").PasteSpecial xlPasteValues
ActiveSheet.Range("A:A,AE:AG").EntireColumn.Delete
Columns("AC").Replace What:="#", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Columns("AC").Replace What:="OUT", Replacement:=P, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Range("AD2").Formula = "=Round(Q2,2)"
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
Range("Q2").PasteSpecial xlPasteValues
Range("AD2").Formula = "=Round(S2,2)"
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
Range("S2").PasteSpecial xlPasteValues
Range("AD2").Formula = "=(Q2*-1)"
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
Range("Q2").PasteSpecial xlPasteValues
Columns("AD:AD").EntireColumn.Delete
With ActiveSheet.Range("A:AC")
.AutoFilter Field:=17, Criteria1:="0"
.AutoFilter Field:=19, Criteria1:="0"
.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
.AutoFilter Field:=17, Criteria1:="0"
.Range("Q2:R" & LastRow).SpecialCells(xlCellTypeVisible).Clear
.AutoFilter
.AutoFilter Field:=19, Criteria1:="0"
.Range("S2:T" & LastRow).SpecialCells(xlCellTypeVisible).Clear
.AutoFilter
'.Range("C2").AutoFill .Range("C2:C" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With
End With
ThisWorkbook.Sheets("Tool").Range("A20:AC20").Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Rows("1").SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
'ActiveWorkbook.Save
'ActiveWorkbook.Close
MsgBox "Done With Farmatting"
End Sub

Answer 1

This isn't a site for reviewing code. There is another one, especially for that purpose in the StackOverflow family. I nevertheless reviewed your code and found nothing that I might point to to make it slow in particular. There should be ways to do the job faster but they require knowledge of your intentions. It seems you have a big worksheet. So it may take a little time but not enough to have a coffee. My comments, therefore, focus on the code's inherent imprecision which makes it prone to crash as well as prone to do untold damage if it's let lose on the wrong worksheet. I have added comments.
Sub Ananplan_to_BPM()
Dim LastRow As Long
Dim LastCol As Long
Dim P As String
' Display a Dialog Box that allows to select a single file.
' The path for the file picked will be stored in fullpath variable
With Application.FileDialog(msoFileDialogFilePicker)
' Makes sure the user can select only one file - quite the opposite
.AllowMultiSelect = True
'Filter to just the following types of files to narrow down selection options
'.Filters.Add "All Files", "*.xlsx; *.xlsm; *.xls; *.xlsb; *.csv"
'Show the dialog box
.Show
'Store in fullpath variable
fullpath = .SelectedItems.Item(1)
End With
' It's a good idea to still check if the file type selected is accurate.
If InStr(fullpath, ".xls") = 0 Or InStr(fullpath, ".csv") = 0 Then
' Quit the procedure if the user didn't select the type of file we need.
Exit Sub
End If
'Open the file selected by the user
Workbooks.Open fullpath
P = InputBox("Please Enter the Version")
Application.ScreenUpdating = False
With ActiveWorkbook
' There isn't a single reference to the ActiveWorkbook
' in the entire 'With' bracket.
' Create a link to the 'With' object by a leading period.
' Example:-
' With .Worksheets(1) ' linked to ActiveWorkbook
' ' below, both cells and Rows.Count of Worksheets(1)
' LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
' End With
' which sheet are you working on here?
LastRow = Cells(Rows.Count, 2).End(xlUp).Row
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
Columns(17).NumberFormat = "0"
Columns(19).NumberFormat = "0"
Columns("I").Copy
Columns("I").Insert Shift:=xlToRight
'Range("AE2").Value = P
'Range("AE2", "AE" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Columns("AE").Copy
Columns("P").PasteSpecial xlPasteValues
' You didn't activate any sheet
ActiveSheet.Range("A:A,AE:AG").EntireColumn.Delete
' everything you do above or below this line
'' is done to the ActiveSheet
Columns("AC").Replace What:="#", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Columns("AC").Replace What:="OUT", Replacement:=P, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
' This should probably be done using a cell format.
' If you need rounded values in later calculations do
' the rounding in later calculations, not in the original data.
Range("AD2").Formula = "=Round(Q2,2)"
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
Range("Q2").PasteSpecial xlPasteValues
Range("AD2").Formula = "=Round(S2,2)"
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
Range("S2").PasteSpecial xlPasteValues
Range("AD2").Formula = "=(Q2*-1)"
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).FillDown
Range("AD2", "AD" & Cells(Rows.Count, "B").End(xlUp).Row).Copy
Range("Q2").PasteSpecial xlPasteValues
Columns("AD:AD").EntireColumn.Delete
End With
With ActiveSheet.Range("A:AC")
' This method will throw an error if there are no visible cells
' why not suppress the display of zero with a CellFormat?
.AutoFilter Field:=17, Criteria1:="0"
.AutoFilter Field:=19, Criteria1:="0"
.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
.AutoFilter Field:=17, Criteria1:="0"
.Range("Q2:R" & LastRow).SpecialCells(xlCellTypeVisible).Clear
.AutoFilter
.AutoFilter Field:=19, Criteria1:="0"
.Range("S2:T" & LastRow).SpecialCells(xlCellTypeVisible).Clear
.AutoFilter
'.Range("C2").AutoFill .Range("C2:C" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With
ThisWorkbook.Sheets("Tool").Range("A20:AC20").Copy
ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues
' you are still working on the undefined ActiveSheet
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Rows("1").SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
'ActiveWorkbook.Save
'ActiveWorkbook.Close
MsgBox "Done With Formatting"
End Sub