Re: MACRO Effeciency

[Auric__]

MZING81 wrote:

> I have a dashboard that calls about 9 macros, it works as it should it's
> just on the slow side,taking baout ten minutes. The macro does work with
> about 100 sheets, merging deleting rows etc.... I have attached the code
> in word document if any one can look it over give me some feedback.
> Any assistance would be greatly appreciated.

I make no promises about this code, but...

Sub workerFunction()
ActiveWorkbook.Sheets.Select
MZING81
Removetextrow 'Compile error: Sub or Function not defined
removeEmptyCells
UnMerge
filter
remerge
Text1 'Using just "Text" is a bad idea...
mergeAllWorksheets
removeSheets
End Sub

Sub MZING81()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim WS As Worksheet
For Each WS In ActiveWorkbook.Worksheets
With WS
.Range("A8").Formula = "MZING81"
.Rows("8").RowHeight = 1.25
.Columns("G").ColumnWidth = 4
End With
Next WS
Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual
End Sub

Sub removeEmptyCells()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim WS As Worksheet
Dim R As Long
On Error GoTo EndMacro

For Each WS In Worksheets
With WS.UsedRange
For R = .Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountA(.Rows(R).EntireRow) = 0 _
Then
.Rows(R).EntireRow.Delete
End If
Next R
End With
Next WS

EndMacro:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual
End Sub

Sub UnMerge()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim WS As Worksheet
For Each WS In Worksheets
WS.UsedRange.UnMerge
Next WS
Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual
End Sub

Sub filter()
Dim WS As Worksheet

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For Each WS In Worksheets
With WS
.AutoFilterMode = False
.Rows("9").AutoFilter

With .AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("D8"), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

.Rows("8").AutoFilter
End With
Next WS

Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual
End Sub

Sub remerge()
'Remergeonly Macro
Dim WS As Worksheet
Dim R As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each WS In Worksheets
With WS
.Columns("A:C").Merge True
.Columns("K:L").Merge True
.Cells(1, 16).Copy
.Cells(3, 7).Paste
.Application.CutCopyMode = False
.Range("G1:J3").Merge True
.Range("F1:J3").Merge True
With .Range("F3:J3")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
.Columns("O:P").Merge True
End With
Next WS
Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual
End Sub

Sub Text1()
Dim WS As Worksheet

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each WS In ActiveWorkbook.Worksheets
With WS
With .Range("F2")
.Formula = "REPORT"
With .Font
.Bold = True
.Name = "Times New Roman"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
End With
.Rows("2:3").RowHeight = 15
With .Range("F2:J2")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
End With
Next WS
Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual
End Sub

Sub mergeAllWorksheets()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ActiveWorkbook.Sheets.Select
' Merges data from all the selected worksheets onto the end of the
' active worksheet.

Const NHR = 1
Dim MWS As Worksheet
Dim AWS As Worksheet
Dim FAR As Long
Dim LR As Long

On Error GoTo EndMacro

Set AWS = ActiveSheet
For Each MWS In ActiveWindow.SelectedSheets
If Not (MWS Is AWS) Then
FAR = AWS.UsedRange.Cells(AWS.UsedRange.Cells.Count).Row + 1
LR = MWS.UsedRange.Cells(MWS.UsedRange.Cells.Count).Row
MWS.Range(MWS.Rows(NHR + 1), MWS.Rows(LR)).Copy AWS.Rows(FAR)
End If
Next MWS
ActiveSheet.PageSetup.PrintArea = "$A$1:$Q$4750"
Dim FoundCell As Range
Dim FirstAddress As String
Dim PrevAddress As String
Dim CurrAddress As String
Dim SearchTerm As String
SearchTerm = "MANNING CHECK REPORT"
With Columns("F:J")
Set FoundCell = .Find(SearchTerm, LookIn:=xlValues, _
LookAt:=xlWhole, MatchCase:=False)
If Not (FoundCell Is Nothing) Then
FoundCell.Name = "FirstAddress"
Do
PrevAddress = FoundCell.Address
FoundCell.Resize(3).EntireRow.Insert
ActiveSheet.HPageBreaks.Add before:=Range(PrevAddress)
Set FoundCell = .FindNext(FoundCell)
Loop While FoundCell.Address <> Range("FirstAddress").Address
Else
MsgBox "No search term found...", vbExclamation
End If
End With
EndMacro:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Sub removeSheets()
Dim strSheet As String
Dim sh As Worksheet
x = MsgBox("keep sheet 1 click ok", vbOKCancel)
If vbOK = x Then
strSheet = "Sheet1"
Application.DisplayAlerts = False
For Each sh In Worksheets
If InStr("," & strSheet & ",", "," & sh.Name & ",", _
vbTextCompare) = 0 Then sh.Delete
Next
Application.DisplayAlerts = True
End If
End Sub


Test on a copy of your workbook before using live.

--
The secret of being miserable is to have leisure to bother about
whether you are happy or not. The cure for it is occupation.
-- George Bernard Shaw

[Martin Brown]

On 23/05/2012 20:55, MZING81 wrote:
> Hi Everyone,

> I have a dashboard that calls about 9 macros, it works as it should it's
> just on the slow side,taking baout ten minutes. The macro does work with
> about 100 sheets, merging deleting rows etc.... I have attached the code
> in word document if any one can look it over give me some feedback.
> Any assistance would be greatly appreciated.
>
>
>

> ActiveWorkbook.Sheets.Select
>
>
> Call MZING81
> Call Removetextrow
> Call removeemptycells
> Call UnMerge
> Call filter
> Call remerge
> Call Text
> Call mergeallworksheets
> Call Removesheets
>
> END SUB

First you need to identify where the Macro is spending its time.
I suggest adding Debug.Print "NameOfRoutine", Time
between each call.

Next optimisation is avoid .Select and operate directly on the object.
Selecting the object is slower than direct action on the object.

Unless you are very fond of seeing how it is going wrap the entire of
the outer level with xlManualCalculation and no screenupdates. There is
otherwise a global update of everything hit between every line.

Also on XL2007 try allowing screen updates - I have known it to be
faster :( although my description would be less glacially slow.

Folding some of the early simpler operations into a single For Each WS
might help a bit and if you can try it on XL2003 I have known some
macros that are mysteriously an order of magnitude slower on XL2007.

ISTR adjusting large numbers of not simply connected RowHeight was one
of those (ie even rows to one size odd ones to another).

Also think hard about the order you do things. Simplifying the data
first and then adding any fancy filters will probably be faster.

Before you can make any progress you need to know where it is wasting
its time. Profile first and then you can spend time on the right thing.

--
Regards,
Martin Brown

[Don Guillett]

It appears that most of your macros could be combined into one.