I wnat to copy several Worksheets, Several Times...

[Dr. Darrell]

I have 17 work sheets in one workbook all labeled similar to this; <<< Item
00001, 3" Valve >>>

I want to do the following:

1) Copy each work sheet 4 times.
a. Rename the originals with an appendage of “1 Eaâ€; <<< Item 00001, 3"
Valve >>>
b. Rename each of the copies with an appendage of “5 Eaâ€, “10 Ea†and
“20 Eaâ€
2) Change the value of Cell M8 in each new worksheet to be 5, 10 and 20 to
correspond to the names of the new worksheets.

I know how to do this by copying the worksheets and renaming them and typing
the value into M8.

Can this be easily done through VBA and what should I use for code?

Darrell

 

[Joel]

Sub copysheets()

Numbersheets = Worksheets.Count

For wscounter = 1 To Numbersheets

Worksheets(wscounter).Copy _
After:=Worksheets(Numbersheets)
ActiveSheet.Range("M8") = 5
ActiveSheet.Name = _
Sheets(wscounter).Name & " 5 Ea"

Worksheets(wscounter).Copy _
After:=Worksheets(Numbersheets)
ActiveSheet.Range("M8") = 10
ActiveSheet.Name = _
Sheets(wscounter).Name & " 10 Ea"

Worksheets(wscounter).Copy _
After:=Worksheets(Numbersheets)
ActiveSheet.Range("M8") = 20
ActiveSheet.Name = _
Sheets(wscounter).Name & " 20 Ea"

Sheets(wscounter).Range("M8") = 1
Sheets(wscounter).Name = Sheets(wscounter).Name & " 1 Ea"
Next wscounter
End Sub

 

[Dr. Darrell]

Joel:

Thank you very much, that worked very nicely. Everything I asked for
happened (the first time.)

The result left me with a considerable amount of manual work to do. I need
to drag Tabs to logical locations and re-color the tabs.

1) The copies of the worksheets were places at the end worksheet list. My
original list of worksheets is similar to this:

Item 00001, 3" Valve, Item 00007, 3" Valve... Item 00011, 2.5" Valve, Item
00016, 2.5" Valve ...

I would like them to be in sequential order (sort of) like the following

Item 00001, 3" Valve 1 Ea, Item 00001, 3" Valve 5 Ea, Item 00001, 3" Valve
10 Ea, Item 00001, 3" Valve 20 Ea... Item 00011, 2.5 1 Ea" Valve, Item 00011,
2.5" Valve 5 Ea, Item 00011, 2.5 10 Ea" Valve, Item 00011, 2.5" Valve 20 Ea,
....


2) All the Tab Colors were copied from the original Tab Color.

I would like all the "... 1 Ea" tabs to be the same color, All the "...5 Ea"
Tabs be the same color but different from the "...1 Ea" Tabs and similar for
"...10 Ea" and "... 20 Ea" Tabs.

Can the code be easily modified to do the above actions.

Darrell

 

[Joel]

I knew you would ask to sort the sheets after I sent the last posting. I was
leaving work and didn't have time to make the change. this code solves your
problem. It was simple. I did things backwards.

Sub copysheets()

Dim colorarray As Variant
colorarray = Array(3, 4, 5, 6)

Numbersheets = Worksheets.Count

For wscounter = Numbersheets To 1 Step -1

Worksheets(wscounter).Copy _
After:=Worksheets(wscounter)
ActiveSheet.Range("M8") = 20
ActiveSheet.Name = _
Sheets(wscounter).Name & " 20 Ea"
ActiveSheet.Tab.ColorIndex = 3

Worksheets(wscounter).Copy _
After:=Worksheets(wscounter)
ActiveSheet.Range("M8") = 10
ActiveSheet.Name = _
Sheets(wscounter).Name & " 10 Ea"
ActiveSheet.Tab.ColorIndex = 4

Worksheets(wscounter).Copy _
After:=Worksheets(wscounter)
ActiveSheet.Range("M8") = 5
ActiveSheet.Name = _
Sheets(wscounter).Name & " 5 Ea"
ActiveSheet.Tab.ColorIndex = 5

Sheets(wscounter).Range("M8") = 1
Sheets(wscounter).Name = Sheets(wscounter).Name & " 1 Ea"
Sheets(wscounter).Tab.ColorIndex = 6

Next wscounter
End Sub

 

[Dr. Darrell]

Joel:

You are the best.

Thank You.

I have one more task to do in this WorkBook, and I will post this as another
entry as well as in response to you.

1) I would like to create a summary worksheet.

2) I would like to merge Cells A1:L1 and enter the File Name (without the
extension). Formatted Arial,Bold,White,24pt text with Black background.

3) In Cells B2:M2 I would like to enter the values from the first worksheet
Cells # S8, T8, U8, V8, W8, X8, Z8, AA8, AC8, AD8 and AE8

4) In Column A3:A70, I would like to enter the text from each Worksheet Tab.

5) On each work sheet there is a value in Column A of “totalsâ€. In these
work sheets, it happens to be on Line 97, 98 or 59.

a. On each line representing each Tab Name, in columns B through M, I would
like to enter the values of column’s S, T, U, V, W, X, Z, AA, AC, AD and AE
from the lines that contain the value “totals†in column A for each of those
worksheets.

Can the existing code be easily modified, or should this be a separate
subroutine?

Darrell


Darrell

 

[Joel]

It is better as a seperate function. Check the cell that are copied to make
sure they are correct. I think there may be some typos in your request.
Make changes as necessary

Sub addsummary()

Worksheets.add _
Before:=Worksheets(1)
ActiveSheet.Name = "Summary"
Range("A1:L1").Select
With Selection
.MergeCells = True
.Name = "Arial"
.Font.Size = 24
.Font.ColorIndex = 2
.Interior.ColorIndex = 1
End With
With Sheets(2)
Range("B2") = .Range("S8")
Range("C2") = .Range("T8")
Range("D2") = .Range("U8")
Range("E2") = .Range("V8")
Range("F2") = .Range("W8")
Range("G2") = .Range("X8")
Range("H2") = .Range("Z8")
Range("I2") = .Range("AA8")
Range("J2") = .Range("AC8")
Range("K2") = .Range("AD8")
Range("L2") = .Range("AE8")

End With

RowCount = 3
For wscounter = 2 To Numbersheets
With Sheets(wscounter)
TotalRow = Columns("$A:$A").Find("Total", xlValues).Row
Cells(RowCount, "A") = .Name
Cells(RowCount, "B") = .Cells(TotalRow, "S")
Cells(RowCount, "C") = .Cells(TotalRow, "T")
Cells(RowCount, "D") = .Cells(TotalRow, "U")
Cells(RowCount, "E") = .Cells(TotalRow, "V")
Cells(RowCount, "F") = .Cells(TotalRow, "W")
Cells(RowCount, "G") = .Cells(TotalRow, "X")
Cells(RowCount, "H") = .Cells(TotalRow, "Y")
Cells(RowCount, "I") = .Cells(TotalRow, "Z")
Cells(RowCount, "J") = .Cells(TotalRow, "AA")
Cells(RowCount, "K") = .Cells(TotalRow, "AB")
Cells(RowCount, "L") = .Cells(TotalRow, "AC")
Cells(RowCount, "M") = .Cells(TotalRow, "AD")

End With

RowCount = RowCount + 1
Next wscounter


End Sub

 

[Dr. Darrell]

Joel:

I had run the previous code both with an existing summary sheet as well as
without one, the result was the same.

If I run the new code from within the VBA Editor, I get a I get a Microsoft
Visual Basic Run-time Error box with “Run-time error '1004â€:
Application-defined or Object-defined error" in it.

If I run the macro from within Excel, I get the same result as with the
previous code. I get a Microsoft Visual Basic Error box with “400†in it.

The line that is highlighted is the very first line, "Sub addsummary()"

The result was the same rather I started with a summary sheet or without a
summary sheet.

 

[Joel]

I just copied the updated code I post on 7/31/2007 12:49 PM PST and put it
into a blank worksheet. I ran with no errors. I also ran it a 2nd time
after the summary sheet was created and again there wre no errors. Try the
same and see what happens. The problem may have to do with some data that
exists on the worksheet. Also make sure no other workbooks are opened.

 

[Dr. Darrell]

Joel:

I get similar results when running on a blank workbook. (With no other Excel
files open.)

Are there any common Option settings, I should address, If not I will speak
with an IT specialist and get his opinion.

I may have a local setting on my machine which causes the Run-time error.

Once again, you've been very helpful. Thank You.

Darrell

 

[Joel]

I'm running with Excel 2003. It may be some of the problems posted on 2007???

 

[Dr. Darrell]

Joel:

I am also running 2003.

Darrell

I'm running with Excel 2003. It may be some of the problems posted on 2007???

 

[Dr. Darrell]

Joel:

You have been a great help. The code you provided me directed me in the
right direction.

With a little analysis and experimentation, I altered your code to look like
this: (It appeared that I had to add “ActiveSheet†to many lines.â€

Sub addsummary()

'test for summary
found = False
For Each ws In Worksheets
If ws.Name = "Summary" Then
found = True
Exit For
End If
Next ws
If found = True Then
Sheets("Summary").Activate
Else
Worksheets.Add _
Before:=Worksheets(1)
ActiveSheet.Name = "Summary"
End If
ActiveSheet.Range("A1:L1").Select
With Selection
..MergeCells = True
..Name = "Arial"
..Font.Size = 24
..Font.ColorIndex = 2
..Interior.ColorIndex = 1
..Value = ActiveWorkbook.Name ' Puts the filename into the cell
..Replace What:=".xls", Replacement:="" ' Removes ".xls" extension from
filename
End With


With Sheets(2)
ActiveSheet.Range("B2") = .Range("S8")
ActiveSheet.Range("C2") = .Range("T8")
ActiveSheet.Range("D2") = .Range("U8")
ActiveSheet.Range("E2") = .Range("V8")
ActiveSheet.Range("F2") = .Range("W8")
ActiveSheet.Range("G2") = .Range("X8")
ActiveSheet.Range("H2") = .Range("Z8")
ActiveSheet.Range("I2") = .Range("AA8")
ActiveSheet.Range("J2") = .Range("AC8")
ActiveSheet.Range("K2") = .Range("AD8")
ActiveSheet.Range("L2") = .Range("AE8")

End With

numberSheets = ActiveWorkbook.Worksheets.Count
RowCount = 3
For wsCounter = 2 To numberSheets

With Sheets(wsCounter)

totalRow = .Columns("A:A").Find(What:="Totals", LookIn:=xlValues).Row
'Searches all of Column A for "Totals" and sets rowTotal to the row number on
which it appears
ActiveSheet.Cells(RowCount, "A") = .Name
ActiveSheet.Cells(RowCount, "B") = .Cells(totalRow, "S")
ActiveSheet.Cells(RowCount, "C") = .Cells(totalRow, "T")
ActiveSheet.Cells(RowCount, "D") = .Cells(totalRow, "U")
ActiveSheet.Cells(RowCount, "E") = .Cells(totalRow, "V")
ActiveSheet.Cells(RowCount, "F") = .Cells(totalRow, "W")
ActiveSheet.Cells(RowCount, "G") = .Cells(totalRow, "X")
ActiveSheet.Cells(RowCount, "H") = .Cells(totalRow, "Z")
ActiveSheet.Cells(RowCount, "I") = .Cells(totalRow, "AA")
ActiveSheet.Cells(RowCount, "J") = .Cells(totalRow, "AC")
ActiveSheet.Cells(RowCount, "K") = .Cells(totalRow, "AD")
ActiveSheet.Cells(RowCount, "L") = .Cells(totalRow, "AE")

End With

RowCount = RowCount + 1
Next wsCounter

End Sub