Home |
Search |
Today's Posts |
#1
|
|||
|
|||
VBA Help
Hi New with VBA,
I've spent some time trying to get his macro to work. There are few issues that I cant get around. This macro needs to work across all the workshhets in the workbook, but only portion funcitons. Also some this code is taken from macro's that I recorded that worked fine indivually but not as a whole. The other error is the AutoFilter portion. I get an 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 If Application.WorksheetFunction.CountA(.Rows(R).Enti reRow) = 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.SortFiel ds.Clear ActiveWorkbook.Worksheets.AutoFilter.Sort.SortFiel ds.Add 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:="ac tual:", 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.CutCopyM ode = 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:P").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.Add befo=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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|