code optimization help

Elrophin

New Member
Joined
Mar 29, 2021
Messages
1
Office Version
  1. 365
Platform
  1. Windows
Hello Mr. Excel forum, I use the code below for formating reports that come from cloud based platforms are have extrahidden html code within the cells (specifically this hidden info CHR 0160, as a space (CHR 032)), and also set some standard formatting on the sheet once the clean up action is performed.

Over the years I added more formatting standards to the process, such as autoset filters, highlight the first row and such... the issue is that has made the code much, much slower than it used to be and I dont have the skills to optimize it. I am looking for help here to do just that.

Woudl anyone be able to optimize this code so that it still does what is intended but faster?


VBA Code:
Sub A0___FormatSheet()

   
      Application.DisplayAlerts = True
      Application.EnableEvents = True   'should be part of Change Event macro


' not part of original remove if error
    Range("A1").Select 'select indicated cell
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select 'crtl+Shift+end selects all active cells until last cell on the edge
    Selection.UnMerge 'unmerge
    Selection.WrapText = False 'unwrap
    Selection.Columns.AutoFit 'autofit columns
    Selection.EntireRow.Hidden = False 'unhide
    Selection.Rows.AutoFit 'autofit rows
    ActiveWindow.DisplayGridlines = False 'remove gridlines
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True 'freeze selected row
    Range("A1").Select 'select indicated cell
    Selection.AutoFilter 'set filter on row selected
    Range("A1").Select 'select indicated cell
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Interior.ColorIndex = 43 'set green color
    Range("A1").Select 'select indicated cell  'selects all again so trim is done on selection
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select 'crtl+Shift+end selects all active cells until last cell on the edge
' not part of original remove if error

   If Application.Calculation = xlCalculationManual Then
      MsgBox "Calculation was OFF will be turned ON upon completion"
   End If
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   Dim Cell As Range
   'Also Treat CHR 0160, as a space (CHR 032)
   Selection.replace what:=Chr(160), Replacement:=Chr(32), _
     LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
   'Trim in Excel removes extra internal spaces, VBA does not
   On Error Resume Next   'in case no text cells in selection
   For Each Cell In Intersect(Selection, _
      Selection.SpecialCells(xlConstants, xlTextValues))
     Cell.Value = Application.Trim(Cell.Value)
     Cells.SpecialCells(xlCellTypeFormulas, xlErrors).Clear 'clear #na
   Next Cell
   On Error GoTo 0
   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
   ActiveSheet.Range("a2").Select 

   
End Sub
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
62,252
Office Version
  1. 365
Platform
  1. Windows
Hi & welcome to MrExcel.
How about
VBA Code:
Sub A0___FormatSheet()

   If Application.Calculation = xlCalculationManual Then
      MsgBox "Calculation was OFF will be turned ON upon completion"
   End If

   With Application
      .DisplayAlerts = False
      .EnableEvents = False   'should be part of Change Event macro
      .ScreenUpdating = False
      .Calculation = xlCalculationManual
   End With
   ActiveWindow.DisplayGridlines = False 'remove gridlines
   ActiveWindow.FreezePanes = False
   
' not part of original remove if error
   With Range("A1", Cells.SpecialCells(xlLastCell))
      .UnMerge 'unmerge
      .WrapText = False 'unwrap
      .Columns.AutoFit 'autofit columns
      .EntireRow.Hidden = False 'unhide
      .Rows.AutoFit 'autofit rows
      .Rows(1).Interior.ColorIndex = 43
      .Rows(1).AutoFilter
      .Replace Chr(160), " ", xlPart, , , , False, False
      .Value = Evaluate("trim(" & .Address & ")")
      On Error Resume Next
      .SpecialCells(xlFormulas, xlErrors).ClearContents
      On Error GoTo 0
   End With
   Range("A2").Select
   ActiveWindow.FreezePanes = True 'freeze selected row
   
   With Application
      .DisplayAlerts = True
      .EnableEvents = True   'should be part of Change Event macro
      .Calculation = xlCalculationAutomatic
   End With
End Sub
 

Forum statistics

Threads
1,141,062
Messages
5,704,050
Members
421,325
Latest member
tapete86

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
Top