This seem to run ok, hope this helps. I had to add 2 extra sheets.add to run on the excel Im using, but I took them back out of the code. Dan
Sub ASRManExcReport()
' Project: HSS500BPRT.PRT Report Manipulation
' Macro: ASRManExcReport
' Company: Fleetwood Homes Central Region Service Center
' Date: Macro recorded 9/30/2004 by Fleetwood Associate
' Programmer: Jason Leidig
' Description: Creates management exception report
'Keyboard Shortcut: N/A
'
Dim intManCellsCol As Integer
Dim intManCellsRow As Integer
Dim strWkBkName As String
Dim strWkBkLocation As String
Dim intStrNumber As Integer
Dim strNewName As String
Dim datDayOldDate As Date
Dim strMEROpenWorkbook As String
'Determine if the "ASR78.xls" is open, if it is open will notify user
'via a message box and will quit the macro
strMEROpenWorkbook = "ManExcepReport78.xls"
For Each Workbook In Application.Workbooks
If Workbook.Name = strMEROpenWorkbook Then
Workbook.Activate
ActiveWindow.Close
Exit Sub
End If
Next
'Add sheets and name each sheet
'----------------------------------------------------
Workbooks.Add
strWkBkName = ActiveWorkbook.Name
'Sheets.Add
'Sheets.Add
Sheets.Add
Sheets.Add
Sheets.Add
Sheets.Add
Sheets.Add
Sheets.Add
Sheets.Add
Sheets.Add
Sheets.Add
Sheets.Add
Sheets.Add
Sheets.Add
Sheets.Add
Sheets("Sheet16").Select
Sheets("Sheet16").Name = "RO St 1-4"
Sheets("Sheet15").Select
Sheets("Sheet15").Name = "RA St 1-4"
Sheets("Sheet14").Select
Sheets("Sheet14").Name = "RP St 1-4"
Sheets("Sheet13").Select
Sheets("Sheet13").Name = "St 8 No Date"
Sheets("Sheet12").Select
Sheets("Sheet12").Name = "St 8 Schedule Date >1 Day"
Sheets("Sheet11").Select
Sheets("Sheet11").Name = "St 8-1111 Code"
Sheets("Sheet10").Select
Sheets("Sheet10").Name = "St 8-2222 Code"
Sheets("Sheet9").Select
Sheets("Sheet9").Name = "3333 Codes"
Sheets("Sheet8").Select
Sheets("Sheet8").Name = "8888 Codes"
Sheets("Sheet7").Select
Sheets("Sheet7").Name = "9998 Codes"
Sheets("Sheet6").Select
Sheets("Sheet6").Name = "6666 Codes"
Sheets("Sheet5").Select
Sheets("Sheet5").Name = "7777 Codes"
Sheets("Sheet4").Select
Sheets("Sheet4").Name = "Over 50's"
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "St 5 > 6"
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "St 6 > 1"
Sheets("Sheet3").Select
Sheets("Sheet3").Name = "St 7 > 7"
'Save new workbook as ManExcepReport78.xls
Windows("ASR78.xls").Activate
strWkBkLocation = ActiveWorkbook.FullName
Windows(strWkBkName).Activate
intStrNumber = Len(strWkBkLocation)
intStrNumber = intStrNumber - 9
strNewName = Left(strWkBkLocation, intStrNumber) & "ManExcepReport78.xls"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:= _
strNewName, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
Application.DisplayAlerts = True
'------Copy data from the ASR78.xls to the RO St 1-4 tab------
'-----------------------------------------------------------
Windows("ASR78.xls").Activate
Selection.AutoFilter Field:=9, Criteria1:="O"
Selection.AutoFilter Field:=8, Criteria1:="1"
Selection.AutoFilter Field:=6, Criteria1:=">=4"
Selection.AutoFilter Field:=2, Criteria1:="=078-*"
'Find last cell and copy data in filtered spreadsheet
ActiveCell.SpecialCells(xlLastCell).Select
intManCellsRow = ActiveCell.Row
intManCellsCol = ActiveCell.Column
Range(Cells(2, 1), Cells(intManCellsRow, intManCellsCol)).Select
Selection.Copy
'Paste data to new workbook tab RO St 1-4
Windows("ManExcepReport78.xls").Activate
Sheets("RO St 1-4").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'Finish copying rest of data to RO St 1-4
Windows("ASR78.xls").Activate
Selection.AutoFilter Field:=8, Criteria1:=">=2", Operator:=xlAnd, _
Criteria2:="<=4"
Selection.AutoFilter Field:=6, Criteria1:=">=3"
'Find last cell and copy data in filtered spreadsheet
ActiveCell.SpecialCells(xlLastCell).Select
intManCellsRow = ActiveCell.Row
intManCellsCol = ActiveCell.Column
If intManCellsRow > 2 Then
Range(Cells(3, 1), Cells(intManCellsRow, intManCellsCol)).Select
Selection.Copy
'Paste data to new workbook tab RO St 1-4
Windows("ManExcepReport78.xls").Activate
Sheets("RO St 1-4").Select
ActiveCell.SpecialCells(xlLastCell).Select
intManCellsRow = ActiveCell.Row
intManCellsRow = intManCellsRow + 1
Range(Cells(intManCellsRow, 1), Cells(intManCellsRow, 1)).Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End If
'------Copy data from ASR78.xls and paste to RA St 1-4------
'---------------------------------------------------------
Windows("ASR78.xls").Activate
Selection.AutoFilter Field:=9, Criteria1:="A"
Selection.AutoFilter Field:=8, Criteria1:="<=4"
Selection.AutoFilter Field:=6, Criteria1:=">=3"
'Find last cell of data and copy data in filtered spreadsheet
ActiveCell.SpecialCells(xlLastCell).Select
intManCellsRow = ActiveCell.Row
intManCellsCol = ActiveCell.Column
Range(Cells(2, 1), Cells(intManCellsRow, intManCellsCol)).Select
Selection.Copy
'Paste data into ManExcepReport78.xls
Windows("ManExcepReport78.xls").Activate
Sheets("RA St 1-4").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'------Copy data from ASR78.xls and paste to RP St 1-4------
'---------------------------------------------------------
Windows("ASR78.xls").Activate
Selection.AutoFilter Field:=9, Criteria1:="P"
Selection.AutoFilter Field:=8, Criteria1:="<=4"
Selection.AutoFilter Field:=6, Criteria1:=">=3"
'Find last cell of data and copy data in filtered spreadsheet
ActiveCell.SpecialCells(xlLastCell).Select
intManCellsRow = ActiveCell.Row
intManCellsCol = ActiveCell.Column
Range(Cells(2, 1), Cells(intManCellsRow, intManCellsCol)).Select
Selection.Copy
'Paste data into ManExcepReport78.xls
Windows("ManExcepReport78.xls").Activate
Sheets("RP St 1-4").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'------Copy data from ASR78.xls and paste to St 8 No Date------
'------------------------------------------------------------
Windows("ASR78.xls").Activate
Selection.AutoFilter Field:=9, Criteria1:="O"
Selection.AutoFilter Field:=8, Criteria1:="8"
Selection.AutoFilter Field:=6, Criteria1:=">=15"
Selection.AutoFilter Field:=5, Criteria1:="="
'Find last cell of data and copy data in filtered spreadsheet
ActiveCell.SpecialCells(xlLastCell).Select
intManCellsRow = ActiveCell.Row
intManCellsCol = ActiveCell.Column
Range(Cells(2, 1), Cells(intManCellsRow, intManCellsCol)).Select
Selection.Copy
Windows("ManExcepReport78.xls").Activate
Sheets("St 8 No Date").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone,
'SkipBlanks:=False, Transpose:=False
'------Copy data from ASR78.xls and paste to St 8 Schedule Date >1 Day------
'-------------------------------------------------------------------------
datDayOldDate = Date
datDayOldDate = datDayOldDate - 2
Windows("ASR78.xls").Activate
Selection.AutoFilter Field:=6
Selection.AutoFilter Field:=5, Criteria1:="<=" & datDayOldDate
Selection.AutoFilter Field:=4, Criteria1:="="
'Find last cell of data and copy data in filtered spreadsheet
ActiveCell.SpecialCells(xlLastCell).Select
intManCellsRow = ActiveCell.Row
intManCellsCol = ActiveCell.Column
Range(Cells(2, 1), Cells(intManCellsRow, intManCellsCol)).Select
Selection.Copy
Windows("ManExcepReport78.xls").Activate
Sheets("St 8 Schedule Date >1 Day").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'------Copy data from ASR78.xls and paste to St 8-1111 Code------
'--------------------------------------------------------------
datDayOldDate = 0
datDayOldDate = Date
datDayOldDate = datDayOldDate - 15
Windows("ASR78.xls").Activate
Selection.AutoFilter Field:=8, Criteria1:="<=8"
Selection.AutoFilter Field:=4, Criteria1:="1111", Operator:=xlOr _
, Criteria2:="3311"
Selection.AutoFilter Field:=5, Criteria1:="<=" & datDayOldDate
'Find last cell of data and copy data in filtered spreadsheet
ActiveCell.SpecialCells(xlLastCell).Select
intManCellsRow = ActiveCell.Row
intManCellsCol = ActiveCell.Column
Range(Cells(2, 1), Cells(intManCellsRow, intManCellsCol)).Select
Selection.Copy
Windows("ManExcepReport78.xls").Activate
Sheets("St 8-1111 Code").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'------Copy data from ASR78.xls and paste to St 8-2222 Code------
'--------------------------------------------------------------
datDayOldDate = 0
datDayOldDate = Date
datDayOldDate = datDayOldDate - 8
Windows("ASR78.xls").Activate
Selection.AutoFilter Field:=4, Criteria1:="2222", Operator:=xlOr _
, Criteria2:="3322"
Selection.AutoFilter Field:=5, Criteria1:="<=" & datDayOldDate
'Find last cell of data and copy data in filtered spreadsheet
ActiveCell.SpecialCells(xlLastCell).Select
intManCellsRow = ActiveCell.Row
intManCellsCol = ActiveCell.Column
Range(Cells(2, 1), Cells(intManCellsRow, intManCellsCol)).Select
Selection.Copy
Windows("ManExcepReport78.xls").Activate
Sheets("St 8-2222 Code").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'------Copy data from ASR78.xls and paste to 3333 Codes------
'----------------------------------------------------------
datDayOldDate = 0
datDayOldDate = Date
datDayOldDate = datDayOldDate - 14
Windows("ASR78.xls").Activate
Selection.AutoFilter Field:=9
Selection.AutoFilter Field:=4, Criteria1:=">=3300", Operator:=xlAnd, _
Criteria2:="<=3399"
Selection.AutoFilter Field:=5, Criteria1:="<=" & datDayOldDate
'Find last cell of data and copy data in filtered spreadsheet
ActiveCell.SpecialCells(xlLastCell).Select
intManCellsRow = ActiveCell.Row
intManCellsCol = ActiveCell.Column
Range(Cells(2, 1), Cells(intManCellsRow, intManCellsCol)).Select
Selection.Copy
Windows("ManExcepReport78.xls").Activate
Sheets("3333 Codes").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'------Copy data from ASR78.xls and paste to 8888 Codes------
'----------------------------------------------------------
Windows("ASR78.xls").Activate
Selection.AutoFilter Field:=4, Criteria1:="8888", Operator:=xlOr _
, Criteria2:="3388"
Selection.AutoFilter Field:=5, Criteria1:="<=" & datDayOldDate
'Find last cell of data and copy data in filtered spreadsheet
ActiveCell.SpecialCells(xlLastCell).Select
intManCellsRow = ActiveCell.Row
intManCellsCol = ActiveCell.Column
Range(Cells(2, 1), Cells(intManCellsRow, intManCellsCol)).Select
Selection.Copy
Windows("ManExcepReport78.xls").Activate
Sheets("8888 Codes").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'------Copy data from ASR78.xls and paste to 9998 Codes------
'----------------------------------------------------------
Windows("ASR78.xls").Activate
Selection.AutoFilter Field:=4, Criteria1:="9998", Operator:=xlOr _
, Criteria2:="3398"
Selection.AutoFilter Field:=5
Selection.AutoFilter Field:=6, Criteria1:=">=2"
'Find last cell of data and copy data in filtered spreadsheet
ActiveCell.SpecialCells(xlLastCell).Select
intManCellsRow = ActiveCell.Row
intManCellsCol = ActiveCell.Column
Range(Cells(2, 1), Cells(intManCellsRow, intManCellsCol)).Select
Selection.Copy
Windows("ManExcepReport78.xls").Activate
Sheets("9998 Codes").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'------Copy data from ASR78.xls and paste to 6666 Codes------
'----------------------------------------------------------
Windows("ASR78.xls").Activate
Selection.AutoFilter Field:=4, Criteria1:="6666"
Selection.AutoFilter Field:=6
'Find last cell of data and copy data in filtered spreadsheet
ActiveCell.SpecialCells(xlLastCell).Select
intManCellsRow = ActiveCell.Row
intManCellsCol = ActiveCell.Column
Range(Cells(2, 1), Cells(intManCellsRow, intManCellsCol)).Select
Selection.Copy
Windows("ManExcepReport78.xls").Activate
Sheets("6666 Codes").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'------Copy data from ASR78.xls and paste to 7777 Codes------
'----------------------------------------------------------
Windows("ASR78.xls").Activate
Selection.AutoFilter Field:=4, Criteria1:="7777"
'Find last cell of data and copy data in filtered spreadsheet
ActiveCell.SpecialCells(xlLastCell).Select
intManCellsRow = ActiveCell.Row
intManCellsCol = ActiveCell.Column
Range(Cells(2, 1), Cells(intManCellsRow, intManCellsCol)).Select
Selection.Copy
Windows("ManExcepReport78.xls").Activate
Sheets("7777 Codes").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'-----Copy data from ASR78.xls and paste to Over 50's------
'----------------------------------------------------------
Windows("ASR78.xls").Activate
Selection.AutoFilter Field:=4
Selection.AutoFilter Field:=6
Selection.AutoFilter Field:=7, Criteria1:=">50"
'Find last cell of data and copy data in filtered spreadsheet
ActiveCell.SpecialCells(xlLastCell).Select
intManCellsRow = ActiveCell.Row
intManCellsCol = ActiveCell.Column
Range(Cells(2, 1), Cells(intManCellsRow, intManCellsCol)).Select
Selection.Copy
Windows("ManExcepReport78.xls").Activate
Sheets("Over 50's").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'------Copy data from ASR78.xls and paste to St 5 > 6------
'----------------------------------------------------------
Windows("ASR78.xls").Activate
Selection.AutoFilter Field:=6, Criteria1:=">=7"
Selection.AutoFilter Field:=7
Selection.AutoFilter Field:=8, Criteria1:="5"
'Find last cell of data and copy data in filtered spreadsheet
ActiveCell.SpecialCells(xlLastCell).Select
intManCellsRow = ActiveCell.Row
intManCellsCol = ActiveCell.Column
Range(Cells(2, 1), Cells(intManCellsRow, intManCellsCol)).Select
Selection.Copy
Windows("ManExcepReport78.xls").Activate
Sheets("St 5 > 6").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'------Copy data from ASR78.xls and paste to St 6 > 1------
'----------------------------------------------------------
Windows("ASR78.xls").Activate
Selection.AutoFilter Field:=6, Criteria1:=">1"
Selection.AutoFilter Field:=8, Criteria1:="6"
'Find last cell of data and copy data in filtered spreadsheet
ActiveCell.SpecialCells(xlLastCell).Select
intManCellsRow = ActiveCell.Row
intManCellsCol = ActiveCell.Column
Range(Cells(2, 1), Cells(intManCellsRow, intManCellsCol)).Select
Selection.Copy
Windows("ManExcepReport78.xls").Activate
Sheets("St 6 > 1").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'------Copy data from ASR78.xls and paste to St 7 > 7------
'----------------------------------------------------------
Windows("ASR78.xls").Activate
Selection.AutoFilter Field:=6, Criteria1:=">=8"
Selection.AutoFilter Field:=8, Criteria1:="7"
'Find last cell of data and copy data in filtered spreadsheet
ActiveCell.SpecialCells(xlLastCell).Select
intManCellsRow = ActiveCell.Row
intManCellsCol = ActiveCell.Column
Range(Cells(2, 1), Cells(intManCellsRow, intManCellsCol)).Select
Selection.Copy
Windows("ManExcepReport78.xls").Activate
Sheets("St 7 > 7").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'Remove criteria from autofilters and close ASR.xls
Windows("ASR78.xls").Activate
Selection.AutoFilter Field:=8
Selection.AutoFilter Field:=6
Selection.AutoFilter Field:=2
Range("A1").Select
End Sub