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

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
If Application.WorksheetFunction.CountA(.Rows(R).Enti reRow) = 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 befo=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

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).Enti reRow) = 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 befo=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

On Thursday, May 24, 2012 12:38:18 PM UTC-5, Auric__ wrote:
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).Enti reRow) = 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 befo=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

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

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