MACRO Effeciency

M

MZING81

Hi Everyone,
I have a dashboard that calls about 9 macros, it works as it should it'
just on the slow side,taking baout ten minutes. The macro does work wit
about 100 sheets, merging deleting rows etc.... I have attached the cod
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

Sub MZING81()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim WS As Worksheet
For Each WS In ActiveWorkbook.Worksheets
With WS
.Range("A8").FormulaR1C1 = "MZING81"
Rows("8:8").Select
Selection.RowHeight = 1.25
Columns("G:G").Select
Selection.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
I
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()
' unmergenew Macro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each WS In Worksheets
With WS
.UsedRange.UnMerge
Application.Goto Reference:="R1C1"
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.UnMerge
End With
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
.Range("9:9").AutoFilter

With .AutoFilter
With .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
End With


Application.Goto Reference:="R8C1"
.Range("8: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.UsedRange
Columns("A:C").Select
Selection.Merge True
Columns("K:L").Select
Selection.Merge True
Application.Goto Reference:="R1C16"
Selection.Copy
Application.Goto Reference:="R3C7"
ActiveSheet.Paste
Range("G1:J3").Select
Application.CutCopyMode = False
Selection.Merge True
Range("F1:J3").Select
Selection.Merge True
Range("F3:J3").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Columns("O:p").Select
Selection.Merge True
End With
Next WS
Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual
END SUB


Sub Text()
Dim WS As Worksheet

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each WS In ActiveWorkbook.Worksheets
With WS
.Range("F2").FormulaR1C1 = "REPORT"
Range("F2").Select
Selection.Font.Bold = True
With Selection.Font
.Name = "Times New Roman"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
Application.Goto Reference:="R2C6"
Rows("2:3").Select
Selection.RowHeight = 15
Range("F2:J2").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
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:$R$100"
ActiveWindow.SmallScroll Down:=4650
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
X = InputBox("keep sheet 1 click ok", vbOKCancel)
If X = OK Then 'MsgBox "hi"

strSheet = "Sheet1"
Application.DisplayAlerts = False
For Each sh In Worksheets
If InStr(1, "," & strSheet & ",", "," & sh.Name & ",", _
vbTextCompare) = 0 Then sh.Delete
Next
Application.DisplayAlerts = True
End If
END SUB
 
A

Auric__

MZING81 said:
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.
Click to expand...

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.
 
M

Martin Brown

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
Click to expand...

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.
 
D

Don Guillett

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.
Click to expand...

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

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

VBA Help 0
Word macro that can call cells out of Excel for a find and replace 0
VBA Coding Help for Beginner 0
Making a macro only work on certain files 2
Run macro on all files in a specific folder 3
Unprotect sheet when Saving As 2
Excel 2003 file gets 25% bigger after changing TP source with VBA 0
Loop through pages and insert header image 0

Top