Running Macro on Multiple Worksheets

V

VexedFist

Any Idea why this only works for the First Worksheet (Hardware)?


Sub DupSheets()

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
SAVESTR(1) = Worksheets("Sheet1").Range("B2").Value
SAVESTR(2) = Worksheets("Sheet1").Range("B3").Value
SAVESTR(3) = Worksheets("Sheet1").Range("B4").Value
SAVESTR(4) = Worksheets("Sheet1").Range("B5").Value
SAVESTR(5) = Worksheets("Sheet1").Range("B6").Value
SAVESTR(6) = Worksheets("Sheet1").Range("B7").Value
SAVESTR(7) = Worksheets("Sheet1").Range("B8").Value
SAVESTR(8) = Worksheets("Sheet1").Range("B9").Value
SAVESTR(9) = Worksheets("Sheet1").Range("B10").Value
SAVESTR(10) = Worksheets("Sheet1").Range("B11").Value
SAVESTR(11) = Worksheets("Sheet1").Range("B12").Value
myWorkseheets(0) = "Sheet1"
myWorkseheets(1) = "Hardware"
myWorkseheets(2) = "Hardware (2)"
myWorkseheets(2) = "Hardware (3)"
myWorkseheets(2) = "Hardware (4)"
myWorkseheets(2) = "Hardware (5)"
myWorkseheets(2) = "Hardware (6)"
myWorkseheets(2) = "Hardware (7)"
myWorkseheets(2) = "Hardware (8)"
myWorkseheets(2) = "Hardware (9)"
myWorkseheets(2) = "Hardware (10)"
myWorkseheets(11) = "Hardware (11)"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Windows("9006 Port Report.xls").Activate
For iCount = 0 To 11
Worksheets(myWorkseheets(iCount)).Select
Worksheets(myWorkseheets(iCount)).Columns("I:I").Select
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("I1").Resize(Range( _
"I" & 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
Worksheets(myWorkseheets(iCount)).Range("B1").Select
Selection.EntireRow.Insert
Worksheets(myWorkseheets(iCount)).Range("N1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("O1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("P1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("Q1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("R1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("S1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("T1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("U1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("V1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("W1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Else
Columns("A:A").ColumnWidth = 2
End If
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
ChDir "C:\Temp Data Files\Reconfigured Data"
ActiveWorkbook.SaveAs Filename:="C:\Temp Data Files
\Reconfigured Data\9006 Port Report.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Sheets("Hardware").Select
Next iCount
Application.ScreenUpdating = False
End Sub


Your assistance is really appreciated.
 
B

Bernie Deitrick

Perhaps because you did not increment your index value?

myWorkseheets(2) = "Hardware (2)"
myWorkseheets(2) = "Hardware (3)"
myWorkseheets(2) = "Hardware (4)"
myWorkseheets(2) = "Hardware (5)"
myWorkseheets(2) = "Hardware (6)"
myWorkseheets(2) = "Hardware (7)"
myWorkseheets(2) = "Hardware (8)"
myWorkseheets(2) = "Hardware (9)"
myWorkseheets(2) = "Hardware (10)"

myWorkseheets(2) = "Hardware (2)"
myWorkseheets(3) = "Hardware (3)"
myWorkseheets(4) = "Hardware (4)"
myWorkseheets(5) = "Hardware (5)"
myWorkseheets(6) = "Hardware (6)"
myWorkseheets(7) = "Hardware (7)"
myWorkseheets(8) = "Hardware (8)"
myWorkseheets(9) = "Hardware (9)"
myWorkseheets(10) = "Hardware (10)"

HTH,
Bernie
MS Excel MVP


VexedFist said:
Any Idea why this only works for the First Worksheet (Hardware)?


Sub DupSheets()

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
SAVESTR(1) = Worksheets("Sheet1").Range("B2").Value
SAVESTR(2) = Worksheets("Sheet1").Range("B3").Value
SAVESTR(3) = Worksheets("Sheet1").Range("B4").Value
SAVESTR(4) = Worksheets("Sheet1").Range("B5").Value
SAVESTR(5) = Worksheets("Sheet1").Range("B6").Value
SAVESTR(6) = Worksheets("Sheet1").Range("B7").Value
SAVESTR(7) = Worksheets("Sheet1").Range("B8").Value
SAVESTR(8) = Worksheets("Sheet1").Range("B9").Value
SAVESTR(9) = Worksheets("Sheet1").Range("B10").Value
SAVESTR(10) = Worksheets("Sheet1").Range("B11").Value
SAVESTR(11) = Worksheets("Sheet1").Range("B12").Value
myWorkseheets(0) = "Sheet1"
myWorkseheets(1) = "Hardware"
myWorkseheets(2) = "Hardware (2)"
myWorkseheets(2) = "Hardware (3)"
myWorkseheets(2) = "Hardware (4)"
myWorkseheets(2) = "Hardware (5)"
myWorkseheets(2) = "Hardware (6)"
myWorkseheets(2) = "Hardware (7)"
myWorkseheets(2) = "Hardware (8)"
myWorkseheets(2) = "Hardware (9)"
myWorkseheets(2) = "Hardware (10)"
myWorkseheets(11) = "Hardware (11)"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Windows("9006 Port Report.xls").Activate
For iCount = 0 To 11
Worksheets(myWorkseheets(iCount)).Select
Worksheets(myWorkseheets(iCount)).Columns("I:I").Select
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("I1").Resize(Range( _
"I" & 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
Worksheets(myWorkseheets(iCount)).Range("B1").Select
Selection.EntireRow.Insert
Worksheets(myWorkseheets(iCount)).Range("N1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("O1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("P1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("Q1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("R1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("S1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("T1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("U1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("V1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("W1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Else
Columns("A:A").ColumnWidth = 2
End If
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
ChDir "C:\Temp Data Files\Reconfigured Data"
ActiveWorkbook.SaveAs Filename:="C:\Temp Data Files
\Reconfigured Data\9006 Port Report.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Sheets("Hardware").Select
Next iCount
Application.ScreenUpdating = False
End Sub


Your assistance is really appreciated.
Click to expand...
 
G

Guest

Bernie,

I think I was sleeping, thanks for catching that.

However it still does NOT delete the unwanted Cells on Hardware sheets 2
thru 11?
the first sheet (Hardware) works, but the others do Not.
Since it keys off of SAVESTR, could that be an issue?

Your help is greatly appreiciated


Bernie Deitrick said:
Perhaps because you did not increment your index value?

myWorkseheets(2) = "Hardware (2)"
myWorkseheets(2) = "Hardware (3)"
myWorkseheets(2) = "Hardware (4)"
myWorkseheets(2) = "Hardware (5)"
myWorkseheets(2) = "Hardware (6)"
myWorkseheets(2) = "Hardware (7)"
myWorkseheets(2) = "Hardware (8)"
myWorkseheets(2) = "Hardware (9)"
myWorkseheets(2) = "Hardware (10)"

myWorkseheets(2) = "Hardware (2)"
myWorkseheets(3) = "Hardware (3)"
myWorkseheets(4) = "Hardware (4)"
myWorkseheets(5) = "Hardware (5)"
myWorkseheets(6) = "Hardware (6)"
myWorkseheets(7) = "Hardware (7)"
myWorkseheets(8) = "Hardware (8)"
myWorkseheets(9) = "Hardware (9)"
myWorkseheets(10) = "Hardware (10)"

HTH,
Bernie
MS Excel MVP


VexedFist said:
Any Idea why this only works for the First Worksheet (Hardware)?


Sub DupSheets()

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
SAVESTR(1) = Worksheets("Sheet1").Range("B2").Value
SAVESTR(2) = Worksheets("Sheet1").Range("B3").Value
SAVESTR(3) = Worksheets("Sheet1").Range("B4").Value
SAVESTR(4) = Worksheets("Sheet1").Range("B5").Value
SAVESTR(5) = Worksheets("Sheet1").Range("B6").Value
SAVESTR(6) = Worksheets("Sheet1").Range("B7").Value
SAVESTR(7) = Worksheets("Sheet1").Range("B8").Value
SAVESTR(8) = Worksheets("Sheet1").Range("B9").Value
SAVESTR(9) = Worksheets("Sheet1").Range("B10").Value
SAVESTR(10) = Worksheets("Sheet1").Range("B11").Value
SAVESTR(11) = Worksheets("Sheet1").Range("B12").Value
myWorkseheets(0) = "Sheet1"
myWorkseheets(1) = "Hardware"
myWorkseheets(2) = "Hardware (2)"
myWorkseheets(2) = "Hardware (3)"
myWorkseheets(2) = "Hardware (4)"
myWorkseheets(2) = "Hardware (5)"
myWorkseheets(2) = "Hardware (6)"
myWorkseheets(2) = "Hardware (7)"
myWorkseheets(2) = "Hardware (8)"
myWorkseheets(2) = "Hardware (9)"
myWorkseheets(2) = "Hardware (10)"
myWorkseheets(11) = "Hardware (11)"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Windows("9006 Port Report.xls").Activate
For iCount = 0 To 11
Worksheets(myWorkseheets(iCount)).Select
Worksheets(myWorkseheets(iCount)).Columns("I:I").Select
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("I1").Resize(Range( _
"I" & 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
Worksheets(myWorkseheets(iCount)).Range("B1").Select
Selection.EntireRow.Insert
Worksheets(myWorkseheets(iCount)).Range("N1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("O1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("P1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("Q1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("R1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("S1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("T1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("U1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("V1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("W1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Else
Columns("A:A").ColumnWidth = 2
End If
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
ChDir "C:\Temp Data Files\Reconfigured Data"
ActiveWorkbook.SaveAs Filename:="C:\Temp Data Files
\Reconfigured Data\9006 Port Report.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Sheets("Hardware").Select
Next iCount
Application.ScreenUpdating = False
End Sub


Your assistance is really appreciated.
Click to expand...
Click to expand...
 
B

Bernie Deitrick

What is it that you want to do? A better description would help - it seems like your SAVESTR is
tied to the specific sheet - or do you want to loop through those as well?

HTH,
Bernie
MS Excel MVP


VexedFist said:
Bernie,

I think I was sleeping, thanks for catching that.

However it still does NOT delete the unwanted Cells on Hardware sheets 2
thru 11?
the first sheet (Hardware) works, but the others do Not.
Since it keys off of SAVESTR, could that be an issue?

Your help is greatly appreiciated


Bernie Deitrick said:
Perhaps because you did not increment your index value?

myWorkseheets(2) = "Hardware (2)"
myWorkseheets(2) = "Hardware (3)"
myWorkseheets(2) = "Hardware (4)"
myWorkseheets(2) = "Hardware (5)"
myWorkseheets(2) = "Hardware (6)"
myWorkseheets(2) = "Hardware (7)"
myWorkseheets(2) = "Hardware (8)"
myWorkseheets(2) = "Hardware (9)"
myWorkseheets(2) = "Hardware (10)"

myWorkseheets(2) = "Hardware (2)"
myWorkseheets(3) = "Hardware (3)"
myWorkseheets(4) = "Hardware (4)"
myWorkseheets(5) = "Hardware (5)"
myWorkseheets(6) = "Hardware (6)"
myWorkseheets(7) = "Hardware (7)"
myWorkseheets(8) = "Hardware (8)"
myWorkseheets(9) = "Hardware (9)"
myWorkseheets(10) = "Hardware (10)"

HTH,
Bernie
MS Excel MVP


VexedFist said:
Any Idea why this only works for the First Worksheet (Hardware)?


Sub DupSheets()

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
SAVESTR(1) = Worksheets("Sheet1").Range("B2").Value
SAVESTR(2) = Worksheets("Sheet1").Range("B3").Value
SAVESTR(3) = Worksheets("Sheet1").Range("B4").Value
SAVESTR(4) = Worksheets("Sheet1").Range("B5").Value
SAVESTR(5) = Worksheets("Sheet1").Range("B6").Value
SAVESTR(6) = Worksheets("Sheet1").Range("B7").Value
SAVESTR(7) = Worksheets("Sheet1").Range("B8").Value
SAVESTR(8) = Worksheets("Sheet1").Range("B9").Value
SAVESTR(9) = Worksheets("Sheet1").Range("B10").Value
SAVESTR(10) = Worksheets("Sheet1").Range("B11").Value
SAVESTR(11) = Worksheets("Sheet1").Range("B12").Value
myWorkseheets(0) = "Sheet1"
myWorkseheets(1) = "Hardware"
myWorkseheets(2) = "Hardware (2)"
myWorkseheets(2) = "Hardware (3)"
myWorkseheets(2) = "Hardware (4)"
myWorkseheets(2) = "Hardware (5)"
myWorkseheets(2) = "Hardware (6)"
myWorkseheets(2) = "Hardware (7)"
myWorkseheets(2) = "Hardware (8)"
myWorkseheets(2) = "Hardware (9)"
myWorkseheets(2) = "Hardware (10)"
myWorkseheets(11) = "Hardware (11)"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Windows("9006 Port Report.xls").Activate
For iCount = 0 To 11
Worksheets(myWorkseheets(iCount)).Select
Worksheets(myWorkseheets(iCount)).Columns("I:I").Select
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("I1").Resize(Range( _
"I" & 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
Worksheets(myWorkseheets(iCount)).Range("B1").Select
Selection.EntireRow.Insert
Worksheets(myWorkseheets(iCount)).Range("N1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("O1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("P1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("Q1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("R1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("S1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("T1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("U1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("V1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("W1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Else
Columns("A:A").ColumnWidth = 2
End If
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
ChDir "C:\Temp Data Files\Reconfigured Data"
ActiveWorkbook.SaveAs Filename:="C:\Temp Data Files
\Reconfigured Data\9006 Port Report.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Sheets("Hardware").Select
Next iCount
Application.ScreenUpdating = False
End Sub


Your assistance is really appreciated.
Click to expand...
Click to expand...
Click to expand...
 
G

Guest

Bernie,

The SAVESTR is copied from Cells B2 thru B11 on Sheet1. I need to loop
through each cell in Column I:I looking for a match on SAVESTR. If a match
is found, the ROW is kept, otherwise it is deleted. On the First Run for the
Hardware sheet it works, however when it moves to Hardware (2), and
SAVESTR(2), it doesn't do the matchup.

This script work fine on the first sheet or if I run Multiple copies.
However I am tring to slim down my Macro sizes.

Bernie Deitrick said:
What is it that you want to do? A better description would help - it seems like your SAVESTR is
tied to the specific sheet - or do you want to loop through those as well?

HTH,
Bernie
MS Excel MVP


VexedFist said:
Bernie,

I think I was sleeping, thanks for catching that.

However it still does NOT delete the unwanted Cells on Hardware sheets 2
thru 11?
the first sheet (Hardware) works, but the others do Not.
Since it keys off of SAVESTR, could that be an issue?

Your help is greatly appreiciated


Bernie Deitrick said:
Perhaps because you did not increment your index value?

myWorkseheets(2) = "Hardware (2)"
myWorkseheets(2) = "Hardware (3)"
myWorkseheets(2) = "Hardware (4)"
myWorkseheets(2) = "Hardware (5)"
myWorkseheets(2) = "Hardware (6)"
myWorkseheets(2) = "Hardware (7)"
myWorkseheets(2) = "Hardware (8)"
myWorkseheets(2) = "Hardware (9)"
myWorkseheets(2) = "Hardware (10)"

myWorkseheets(2) = "Hardware (2)"
myWorkseheets(3) = "Hardware (3)"
myWorkseheets(4) = "Hardware (4)"
myWorkseheets(5) = "Hardware (5)"
myWorkseheets(6) = "Hardware (6)"
myWorkseheets(7) = "Hardware (7)"
myWorkseheets(8) = "Hardware (8)"
myWorkseheets(9) = "Hardware (9)"
myWorkseheets(10) = "Hardware (10)"

HTH,
Bernie
MS Excel MVP


Any Idea why this only works for the First Worksheet (Hardware)?


Sub DupSheets()

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
SAVESTR(1) = Worksheets("Sheet1").Range("B2").Value
SAVESTR(2) = Worksheets("Sheet1").Range("B3").Value
SAVESTR(3) = Worksheets("Sheet1").Range("B4").Value
SAVESTR(4) = Worksheets("Sheet1").Range("B5").Value
SAVESTR(5) = Worksheets("Sheet1").Range("B6").Value
SAVESTR(6) = Worksheets("Sheet1").Range("B7").Value
SAVESTR(7) = Worksheets("Sheet1").Range("B8").Value
SAVESTR(8) = Worksheets("Sheet1").Range("B9").Value
SAVESTR(9) = Worksheets("Sheet1").Range("B10").Value
SAVESTR(10) = Worksheets("Sheet1").Range("B11").Value
SAVESTR(11) = Worksheets("Sheet1").Range("B12").Value
myWorkseheets(0) = "Sheet1"
myWorkseheets(1) = "Hardware"
myWorkseheets(2) = "Hardware (2)"
myWorkseheets(2) = "Hardware (3)"
myWorkseheets(2) = "Hardware (4)"
myWorkseheets(2) = "Hardware (5)"
myWorkseheets(2) = "Hardware (6)"
myWorkseheets(2) = "Hardware (7)"
myWorkseheets(2) = "Hardware (8)"
myWorkseheets(2) = "Hardware (9)"
myWorkseheets(2) = "Hardware (10)"
myWorkseheets(11) = "Hardware (11)"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Windows("9006 Port Report.xls").Activate
For iCount = 0 To 11
Worksheets(myWorkseheets(iCount)).Select
Worksheets(myWorkseheets(iCount)).Columns("I:I").Select
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("I1").Resize(Range( _
"I" & 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
Worksheets(myWorkseheets(iCount)).Range("B1").Select
Selection.EntireRow.Insert
Worksheets(myWorkseheets(iCount)).Range("N1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("O1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("P1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("Q1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("R1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("S1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("T1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("U1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("V1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("W1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Else
Columns("A:A").ColumnWidth = 2
End If
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
ChDir "C:\Temp Data Files\Reconfigured Data"
ActiveWorkbook.SaveAs Filename:="C:\Temp Data Files
\Reconfigured Data\9006 Port Report.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Sheets("Hardware").Select
Next iCount
Application.ScreenUpdating = False
End Sub


Your assistance is really appreciated.
Click to expand...
Click to expand...
Click to expand...
 
B

Bernie Deitrick

VF,

Change

If Not delRange Is Nothing Then delRange.EntireRow.Delete

to

If Not delRange Is Nothing Then
delRange.EntireRow.Delete
Set delRange = Nothing
End If

HTH,
Bernie
MS Excel MVP


VexedFist said:
Bernie,

The SAVESTR is copied from Cells B2 thru B11 on Sheet1. I need to loop
through each cell in Column I:I looking for a match on SAVESTR. If a match
is found, the ROW is kept, otherwise it is deleted. On the First Run for the
Hardware sheet it works, however when it moves to Hardware (2), and
SAVESTR(2), it doesn't do the matchup.

This script work fine on the first sheet or if I run Multiple copies.
However I am tring to slim down my Macro sizes.

Bernie Deitrick said:
What is it that you want to do? A better description would help - it seems like your SAVESTR is
tied to the specific sheet - or do you want to loop through those as well?

HTH,
Bernie
MS Excel MVP


VexedFist said:
Bernie,

I think I was sleeping, thanks for catching that.

However it still does NOT delete the unwanted Cells on Hardware sheets 2
thru 11?
the first sheet (Hardware) works, but the others do Not.
Since it keys off of SAVESTR, could that be an issue?

Your help is greatly appreiciated


:

Perhaps because you did not increment your index value?

myWorkseheets(2) = "Hardware (2)"
myWorkseheets(2) = "Hardware (3)"
myWorkseheets(2) = "Hardware (4)"
myWorkseheets(2) = "Hardware (5)"
myWorkseheets(2) = "Hardware (6)"
myWorkseheets(2) = "Hardware (7)"
myWorkseheets(2) = "Hardware (8)"
myWorkseheets(2) = "Hardware (9)"
myWorkseheets(2) = "Hardware (10)"

myWorkseheets(2) = "Hardware (2)"
myWorkseheets(3) = "Hardware (3)"
myWorkseheets(4) = "Hardware (4)"
myWorkseheets(5) = "Hardware (5)"
myWorkseheets(6) = "Hardware (6)"
myWorkseheets(7) = "Hardware (7)"
myWorkseheets(8) = "Hardware (8)"
myWorkseheets(9) = "Hardware (9)"
myWorkseheets(10) = "Hardware (10)"

HTH,
Bernie
MS Excel MVP


Any Idea why this only works for the First Worksheet (Hardware)?


Sub DupSheets()

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
SAVESTR(1) = Worksheets("Sheet1").Range("B2").Value
SAVESTR(2) = Worksheets("Sheet1").Range("B3").Value
SAVESTR(3) = Worksheets("Sheet1").Range("B4").Value
SAVESTR(4) = Worksheets("Sheet1").Range("B5").Value
SAVESTR(5) = Worksheets("Sheet1").Range("B6").Value
SAVESTR(6) = Worksheets("Sheet1").Range("B7").Value
SAVESTR(7) = Worksheets("Sheet1").Range("B8").Value
SAVESTR(8) = Worksheets("Sheet1").Range("B9").Value
SAVESTR(9) = Worksheets("Sheet1").Range("B10").Value
SAVESTR(10) = Worksheets("Sheet1").Range("B11").Value
SAVESTR(11) = Worksheets("Sheet1").Range("B12").Value
myWorkseheets(0) = "Sheet1"
myWorkseheets(1) = "Hardware"
myWorkseheets(2) = "Hardware (2)"
myWorkseheets(2) = "Hardware (3)"
myWorkseheets(2) = "Hardware (4)"
myWorkseheets(2) = "Hardware (5)"
myWorkseheets(2) = "Hardware (6)"
myWorkseheets(2) = "Hardware (7)"
myWorkseheets(2) = "Hardware (8)"
myWorkseheets(2) = "Hardware (9)"
myWorkseheets(2) = "Hardware (10)"
myWorkseheets(11) = "Hardware (11)"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Windows("9006 Port Report.xls").Activate
For iCount = 0 To 11
Worksheets(myWorkseheets(iCount)).Select
Worksheets(myWorkseheets(iCount)).Columns("I:I").Select
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("I1").Resize(Range( _
"I" & 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
Worksheets(myWorkseheets(iCount)).Range("B1").Select
Selection.EntireRow.Insert
Worksheets(myWorkseheets(iCount)).Range("N1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("O1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("P1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("Q1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("R1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("S1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("T1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("U1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("V1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("W1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Else
Columns("A:A").ColumnWidth = 2
End If
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
ChDir "C:\Temp Data Files\Reconfigured Data"
ActiveWorkbook.SaveAs Filename:="C:\Temp Data Files
\Reconfigured Data\9006 Port Report.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Sheets("Hardware").Select
Next iCount
Application.ScreenUpdating = False
End Sub


Your assistance is really appreciated.
Click to expand...
Click to expand...
Click to expand...
 
G

Guest

Bernie,

That did the Trick.
IS there an easy way to do this with my other worksheets?
the problem I have is the Worksheet names are all different.
The SAVESTR is NOT referenced in a Cell, I aassume the below would work:

SAVESTR(1) = "SomeText Value 1"
SAVESTR(2) = "SomeOtherText"
SAVESTR(3) = "Even More Text"
myWorkseheets(1) = "Digital Phones"
myWorkseheets(2) = "Analog Phones"
myWorkseheets(3) = "Digital Trunks"

Your thoughts would be appreciated



Bernie Deitrick said:
VF,

Change

If Not delRange Is Nothing Then delRange.EntireRow.Delete

to

If Not delRange Is Nothing Then
delRange.EntireRow.Delete
Set delRange = Nothing
End If

HTH,
Bernie
MS Excel MVP


VexedFist said:
Bernie,

The SAVESTR is copied from Cells B2 thru B11 on Sheet1. I need to loop
through each cell in Column I:I looking for a match on SAVESTR. If a match
is found, the ROW is kept, otherwise it is deleted. On the First Run for the
Hardware sheet it works, however when it moves to Hardware (2), and
SAVESTR(2), it doesn't do the matchup.

This script work fine on the first sheet or if I run Multiple copies.
However I am tring to slim down my Macro sizes.

Bernie Deitrick said:
What is it that you want to do? A better description would help - it seems like your SAVESTR is
tied to the specific sheet - or do you want to loop through those as well?

HTH,
Bernie
MS Excel MVP


Bernie,

I think I was sleeping, thanks for catching that.

However it still does NOT delete the unwanted Cells on Hardware sheets 2
thru 11?
the first sheet (Hardware) works, but the others do Not.
Since it keys off of SAVESTR, could that be an issue?

Your help is greatly appreiciated


:

Perhaps because you did not increment your index value?

myWorkseheets(2) = "Hardware (2)"
myWorkseheets(2) = "Hardware (3)"
myWorkseheets(2) = "Hardware (4)"
myWorkseheets(2) = "Hardware (5)"
myWorkseheets(2) = "Hardware (6)"
myWorkseheets(2) = "Hardware (7)"
myWorkseheets(2) = "Hardware (8)"
myWorkseheets(2) = "Hardware (9)"
myWorkseheets(2) = "Hardware (10)"

myWorkseheets(2) = "Hardware (2)"
myWorkseheets(3) = "Hardware (3)"
myWorkseheets(4) = "Hardware (4)"
myWorkseheets(5) = "Hardware (5)"
myWorkseheets(6) = "Hardware (6)"
myWorkseheets(7) = "Hardware (7)"
myWorkseheets(8) = "Hardware (8)"
myWorkseheets(9) = "Hardware (9)"
myWorkseheets(10) = "Hardware (10)"

HTH,
Bernie
MS Excel MVP


Any Idea why this only works for the First Worksheet (Hardware)?


Sub DupSheets()

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
SAVESTR(1) = Worksheets("Sheet1").Range("B2").Value
SAVESTR(2) = Worksheets("Sheet1").Range("B3").Value
SAVESTR(3) = Worksheets("Sheet1").Range("B4").Value
SAVESTR(4) = Worksheets("Sheet1").Range("B5").Value
SAVESTR(5) = Worksheets("Sheet1").Range("B6").Value
SAVESTR(6) = Worksheets("Sheet1").Range("B7").Value
SAVESTR(7) = Worksheets("Sheet1").Range("B8").Value
SAVESTR(8) = Worksheets("Sheet1").Range("B9").Value
SAVESTR(9) = Worksheets("Sheet1").Range("B10").Value
SAVESTR(10) = Worksheets("Sheet1").Range("B11").Value
SAVESTR(11) = Worksheets("Sheet1").Range("B12").Value
myWorkseheets(0) = "Sheet1"
myWorkseheets(1) = "Hardware"
myWorkseheets(2) = "Hardware (2)"
myWorkseheets(2) = "Hardware (3)"
myWorkseheets(2) = "Hardware (4)"
myWorkseheets(2) = "Hardware (5)"
myWorkseheets(2) = "Hardware (6)"
myWorkseheets(2) = "Hardware (7)"
myWorkseheets(2) = "Hardware (8)"
myWorkseheets(2) = "Hardware (9)"
myWorkseheets(2) = "Hardware (10)"
myWorkseheets(11) = "Hardware (11)"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Windows("9006 Port Report.xls").Activate
For iCount = 0 To 11
Worksheets(myWorkseheets(iCount)).Select
Worksheets(myWorkseheets(iCount)).Columns("I:I").Select
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("I1").Resize(Range( _
"I" & 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
Worksheets(myWorkseheets(iCount)).Range("B1").Select
Selection.EntireRow.Insert
Worksheets(myWorkseheets(iCount)).Range("N1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("O1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("P1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("Q1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("R1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("S1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("T1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("U1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("V1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Worksheets(myWorkseheets(iCount)).Range("W1").FormulaR1C1 =
"=SUM(R[1]C:R[500]C)"
Else
Columns("A:A").ColumnWidth = 2
End If
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
ChDir "C:\Temp Data Files\Reconfigured Data"
ActiveWorkbook.SaveAs Filename:="C:\Temp Data Files
\Reconfigured Data\9006 Port Report.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Sheets("Hardware").Select
Next iCount
Application.ScreenUpdating = False
End Sub


Your assistance is really appreciated.
Click to expand...
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

My Macro does NOT Delete ROWS?? 1
My Macro Won't Delete Rows?? 3
Changing the CONST Variable 1
Error 1004 3
Run Time Error '1004' 1
Deleting Sheet with No Data 7
End of Page 7
Help! Query Refreshing 2

Top