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