My Macro does not DELETE the ROWS from the specified Worksheet whene SAVESTR
is NOT Found.

If SAVESTR is found it deletes the other ROWS. However I need to be left
with a blank sheet if SAVESTR is not found in the specifed column.

Sub DupDigitalSheets()
'
' DupDigitalSheets Macro
' Macro Created On 4/12/2007
'

'
Dim myWorkseheets(11) As String
Dim SAVESTR(11) As String
Dim iCount As Integer
Dim myRange As Range
Dim cell As Range
Dim delRange As Range
Const startRptName = "9006 "
Const stopRptName = " Report.xls"
SAVESTR(0) = "EXTVCML"
SAVESTR(1) = "FICTICS"
SAVESTR(2) = "KYSETDY"
SAVESTR(3) = "KYSETJR"
SAVESTR(4) = "OPSLMA"
SAVESTR(5) = "OPST1"
SAVESTR(6) = "OPTI"
SAVESTR(7) = "PHANTOM"
SAVESTR(8) = "RP4327"
SAVESTR(9) = "RPHONE"
SAVESTR(10) = "SADCM"
myWorkseheets(0) = "Extvcml"
myWorkseheets(1) = "FICTICS"
myWorkseheets(2) = "KYSETDY"
myWorkseheets(3) = "KYSETJR"
myWorkseheets(4) = "OPSLMA"
myWorkseheets(5) = "OPST1"
myWorkseheets(6) = "OptieSets"
myWorkseheets(7) = "PHANTOM"
myWorkseheets(8) = "RP4327"
myWorkseheets(9) = "RPHONE"
myWorkseheets(10) = "SADCMs"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For iCount = 0 To 10
Windows("9006 Digital Line Report.xls").Activate
Worksheets(myWorkseheets(iCount)).Select
Worksheets(myWorkseheets(iCount)).Columns("X:X").S elect
On Error Resume Next
Selection.Find(What:=SAVESTR(iCount), After:=ActiveCell,
LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:= _
False).Activate
If Err.Number < 91 And Err.Number < 0 Then
MsgBox "Unresolved Error"
Exit Sub
End If
If ActiveCell.Row 1 Then
Set myRange =
Worksheets(myWorkseheets(iCount)).Range("X1").Resi ze(Range( _
"X" & Rows.Count).End(xlUp).Row, 1)
For Each cell In myRange
If cell.Value < SAVESTR(iCount) Then
If delRange Is Nothing Then
Set delRange = cell
Else
Set delRange = Union(delRange, cell)
End If
End If
Next cell
If Not delRange Is Nothing Then delRange.EntireRow.Delete
Set delRange = Nothing
Worksheets(myWorkseheets(iCount)).Range("B1").Sele ct
Worksheets(myWorkseheets(iCount)).Move
ChDir "C:\Temp Data Files\Reconfigured Data"
ActiveWorkbook.SaveAs Filename:= _
startRptName + myWorkseheets(iCount) + stopRptName,
FileFormat:= _
xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWindow.WindowState = xlMinimized
Else
Worksheets(myWorkseheets(iCount)).Range("B1").Sele ct
Worksheets(myWorkseheets(iCount)).Move
ChDir "C:\Temp Data Files\Reconfigured Data"
ActiveWorkbook.SaveAs Filename:= _
startRptName + myWorkseheets(iCount) + stopRptName,
FileFormat:= _
xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWindow.WindowState = xlMinimized
End If
Next iCount
Application.ScreenUpdating = False
End Sub


Any assistance will be appreciated.

Pls post in ONE group only
--
Don Guillett
SalesAid Software

"VexedFist" wrote in message
...
My Macro does not DELETE the ROWS from the specified Worksheet whene
SAVESTR
is NOT Found.

If SAVESTR is found it deletes the other ROWS. However I need to be left
with a blank sheet if SAVESTR is not found in the specifed column.

Sub DupDigitalSheets()
'
' DupDigitalSheets Macro
' Macro Created On 4/12/2007
'

'
Dim myWorkseheets(11) As String
Dim SAVESTR(11) As String
Dim iCount As Integer
Dim myRange As Range
Dim cell As Range
Dim delRange As Range
Const startRptName = "9006 "
Const stopRptName = " Report.xls"
SAVESTR(0) = "EXTVCML"
SAVESTR(1) = "FICTICS"
SAVESTR(2) = "KYSETDY"
SAVESTR(3) = "KYSETJR"
SAVESTR(4) = "OPSLMA"
SAVESTR(5) = "OPST1"
SAVESTR(6) = "OPTI"
SAVESTR(7) = "PHANTOM"
SAVESTR(8) = "RP4327"
SAVESTR(9) = "RPHONE"
SAVESTR(10) = "SADCM"
myWorkseheets(0) = "Extvcml"
myWorkseheets(1) = "FICTICS"
myWorkseheets(2) = "KYSETDY"
myWorkseheets(3) = "KYSETJR"
myWorkseheets(4) = "OPSLMA"
myWorkseheets(5) = "OPST1"
myWorkseheets(6) = "OptieSets"
myWorkseheets(7) = "PHANTOM"
myWorkseheets(8) = "RP4327"
myWorkseheets(9) = "RPHONE"
myWorkseheets(10) = "SADCMs"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For iCount = 0 To 10
Windows("9006 Digital Line Report.xls").Activate
Worksheets(myWorkseheets(iCount)).Select
Worksheets(myWorkseheets(iCount)).Columns("X:X").S elect
On Error Resume Next
Selection.Find(What:=SAVESTR(iCount), After:=ActiveCell,
LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:= _
False).Activate
If Err.Number < 91 And Err.Number < 0 Then
MsgBox "Unresolved Error"
Exit Sub
End If
If ActiveCell.Row 1 Then
Set myRange =
Worksheets(myWorkseheets(iCount)).Range("X1").Resi ze(Range( _
"X" & Rows.Count).End(xlUp).Row, 1)
For Each cell In myRange
If cell.Value < SAVESTR(iCount) Then
If delRange Is Nothing Then
Set delRange = cell
Else
Set delRange = Union(delRange, cell)
End If
End If
Next cell
If Not delRange Is Nothing Then delRange.EntireRow.Delete
Set delRange = Nothing
Worksheets(myWorkseheets(iCount)).Range("B1").Sele ct
Worksheets(myWorkseheets(iCount)).Move
ChDir "C:\Temp Data Files\Reconfigured Data"
ActiveWorkbook.SaveAs Filename:= _
startRptName + myWorkseheets(iCount) + stopRptName,
FileFormat:= _
xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWindow.WindowState = xlMinimized
Else
Worksheets(myWorkseheets(iCount)).Range("B1").Sele ct
Worksheets(myWorkseheets(iCount)).Move
ChDir "C:\Temp Data Files\Reconfigured Data"
ActiveWorkbook.SaveAs Filename:= _
startRptName + myWorkseheets(iCount) + stopRptName,
FileFormat:= _
xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWindow.WindowState = xlMinimized
End If
Next iCount
Application.ScreenUpdating = False
End Sub


Any assistance will be appreciated.