VBA Help

[MZING81]

Hi New with VBA,

I've spent some time trying to get his macro to work. There are fe
issues that I cant get around. This macro needs to work across all th
workshhets in the workbook, but only portion funcitons. Also some thi
code is taken from macro's that I recorded that worked fine indivuall
but not as a whole. The other error is the AutoFilter portion. I get a
error that stating an issue with the method.




SUB MReport


Dim WS As Worksheet
Dim R As Long

On Error GoTo EndMacro

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

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:


' unmergenew Macro

For Each WS In Worksheets
With WS.UsedRange
Application.WorksheetFunction.Application.Goto Reference:="R1C1"
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.UnMerge

End With
Next WS

' filtersort Macro


For Each WS In Worksheets
With WS.UsedRange
Application.WorksheetFunction.Application.Goto Reference:="R8C1"
Rows("8:8").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets.AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets.AutoFilter.Sort.SortFields.Ad
Key:=Range("D8"), SortOn:=xlSortOnValues, Order:=xlAscending
DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply

End With




'Remove head count data macro


With WS.UsedRange

Application.WorksheetFunction.Cells.Find(What:="actual:"
After:=ActiveCell, LookIn:=xlFormulas, lookat _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext
MatchCase:= _
False, SearchFormat:=False).Activate
Rows.Select
Selection.Delete Shift:=xlUp

End With


'Remergeonly Macro


With WS.UsedRange

Columns("A:C").Select
Selection.Merge True
Columns("K:L").Select
Selection.Merge True
Application.WorksheetFunction.Application.Goto Reference:="R1C16"
Selection.Copy
Application.WorksheetFunction.Application.Goto Reference:="R3C7"
ActiveSheet.Paste
Range("G1:J3").Select
Application.WorksheetFunction.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
Columns("O").Select
Selection.Merge True

End With

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
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:=2900
ActiveSheet.PageSetup.PrintArea = "$A$1:$Q$3000"


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("G:K")
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.Ad
before:=Range(PrevAddress)
Set FoundCell = .FindNext(FoundCell)
Loop While FoundCell.Address <>
Range("FirstAddress").Address
Else
MsgBox "No search term found...", vbExclamation
End If

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub