rgagli1
asked on
For next ws macro
I need some help with a macro that cycles through all the active worksheets in a workbook. I have the formulas and vba setup to calculate formulas and then save the worksheet as a seperate file but I can't get the spreadsheet to cycle through each worksheet. For the save, it only saves the same worksheet by the number of worksheets in the workbook (not the actual different worksheets). Any ideas on how to make it change after performing the save as in the final step? Also, is it possible to transfer the color scheme to the new workbook?
Sub Summarize()
Dim i
Dim myrange
Dim bottomCell As Range
Dim s
Dim y
Dim bottomCellminus As Integer
Dim ws As Worksheet
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationManual
For Each ws In ActiveWorkbook.Worksheets
' Added: The next line will display which Worksheet is in progress
Application.StatusBar = "Working on:" & ws.Name & _
", which is number " & ws.index & _
" out of " & ActiveWorkbook.Worksheets.Count & _
" Sheet(s)."
With ws.PageSetup
'.PrintTitleRows = "$3:$12"
.CenterHeader = "&A"
.CenterFooter = "Page &P of &N"
.LeftMargin = Application.InchesToPoints(0.694444444444444)
.RightMargin = Application.InchesToPoints(0.694444444444444)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0.25)
.FooterMargin = Application.InchesToPoints(0.25)
'.PrintHeadings = False
'.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLegal
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
'.FitToPagesWide = 1
'.FitToPagesTall = False
End With
Set bottomCell = Range("C15").End(xlDown)
bottomCellminus = bottomCell.Row - 1
X = 15
Do While X <= bottomCell.Row
Cells(X, 15) = "=SUM(C" & X & ":N" & X & ")"
Cells(X, 17) = "=(+P" & X & "-O" & X & ")"
Cells(X, 19) = "=(+R" & X & "-O" & X & ")"
Columns("B:S").Select
X = X + 1
Loop
Cells(bottomCell.Row, 3) = "=SUM(C15:C" & bottomCellminus & ")"
Cells(bottomCell.Row, 4) = "=SUM(D15:D" & bottomCellminus & ")"
Cells(bottomCell.Row, 5) = "=SUM(E15:E" & bottomCellminus & ")"
Cells(bottomCell.Row, 6) = "=SUM(F15:F" & bottomCellminus & ")"
Cells(bottomCell.Row, 7) = "=SUM(G15:G" & bottomCellminus & ")"
Cells(bottomCell.Row, 8) = "=SUM(H15:H" & bottomCellminus & ")"
Cells(bottomCell.Row, 9) = "=SUM(I15:I" & bottomCellminus & ")"
Cells(bottomCell.Row, 10) = "=SUM(J15:J" & bottomCellminus & ")"
Cells(bottomCell.Row, 11) = "=SUM(K15:K" & bottomCellminus & ")"
Cells(bottomCell.Row, 12) = "=SUM(L15:L" & bottomCellminus & ")"
Cells(bottomCell.Row, 13) = "=SUM(M15:M" & bottomCellminus & ")"
Cells(bottomCell.Row, 14) = "=SUM(N15:N" & bottomCellminus & ")"
Cells(bottomCell.Row, 15) = "=SUM(O15:O" & bottomCellminus & ")"
Cells(bottomCell.Row, 16) = "=SUM(P15:P" & bottomCellminus & ")"
Cells(bottomCell.Row, 17) = "=SUM(Q15:Q" & bottomCellminus & ")"
Cells(bottomCell.Row, 18) = "=SUM(R15:R" & bottomCellminus & ")"
Cells(bottomCell.Row, 19) = "=SUM(S15:S" & bottomCellminus & ")"
Columns("C:S").Select
Selection.NumberFormat = "(#,###);[Red](#,###);_(* 0_)"
Columns("A:S").EntireColumn.AutoFit
bottomCell = 0
bottomCellminus = 0
MName = ActiveSheet.Name & ".xls"
MDir = ActiveWorkbook.Path
ActiveWorkbook.SaveAs Filename:=MDir & "\" & MName
Next ws
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False ' <-- Erases the bar & restores control to Excel.
End Sub
I think this is what you are after?
Regards,
Rory
Regards,
Rory
Sub Summarize()
Dim i
Dim myrange
Dim bottomCell As Range
Dim s
Dim y
Dim bottomCellminus As Integer
Dim ws As Worksheet
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationManual
For Each ws In ActiveWorkbook.Worksheets
' Added: The next line will display which Worksheet is in progress
Application.StatusBar = "Working on:" & ws.Name & _
", which is number " & ws.Index & _
" out of " & ActiveWorkbook.Worksheets.Count & _
" Sheet(s)."
With ws
With .PageSetup
'.PrintTitleRows = "$3:$12"
.CenterHeader = "&A"
.CenterFooter = "Page &P of &N"
.LeftMargin = Application.InchesToPoints(0.694444444444444)
.RightMargin = Application.InchesToPoints(0.694444444444444)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0.25)
.FooterMargin = Application.InchesToPoints(0.25)
'.PrintHeadings = False
'.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLegal
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
'.FitToPagesWide = 1
'.FitToPagesTall = False
End With
Set bottomCell = .Range("C15").End(xlDown)
bottomCellminus = bottomCell.Row - 1
X = 15
Do While X <= bottomCell.Row
.Cells(X, 15) = "=SUM(C" & X & ":N" & X & ")"
.Cells(X, 17) = "=(+P" & X & "-O" & X & ")"
.Cells(X, 19) = "=(+R" & X & "-O" & X & ")"
' .Columns("B:S").Select
X = X + 1
Loop
' set totals formulas
bottomCell.Resize(, 17).FormulaR1C1 = "=SUM(R15C:R[-1]C)"
With .Columns("C:S")
.NumberFormat = "(#,###);[Red](#,###);_(* 0_)"
.EntireColumn.AutoFit
End With
' bottomCell = 0
bottomCellminus = 0
MName = .Name & ".xls"
MDir = ActiveWorkbook.Path
.SaveAs Filename:=MDir & "\" & MName
End With
Next ws
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False ' <-- Erases the bar & restores control to Excel.
End SubASKER
For both examples, I'm getting an error. It doesn't look like the first one actually moves between the spreadsheets. It only sits on the first one. Then for both I get the following error:
Run-time error: '6'
overflow
on this line of code:
bottomCellminus = bottomCell.Row - 1
Run-time error: '6'
overflow
on this line of code:
bottomCellminus = bottomCell.Row - 1
Change line-7 which is this...
Dim bottomCellminus As Integer
to this...
Dim bottomCellminus As long
This would fix that...
Dim bottomCellminus As Integer
to this...
Dim bottomCellminus As long
This would fix that...
Yup - missed that one.
To clarify - you should never use an Integer variable to hold row numbers since Integers only go up to 32767 and there are 65536 rows in a worksheet (in versions prior to 2007, where there are over a million)
Regards,
Rory
To clarify - you should never use an Integer variable to hold row numbers since Integers only go up to 32767 and there are 65536 rows in a worksheet (in versions prior to 2007, where there are over a million)
Regards,
Rory
ASKER
Whenever the spreadsheet saves it keeps all the other worksheets. Is there a way to copy only one or a few spreadsheets to a new workbook?
Try this version:
Sub Summarize()
Dim i
Dim myrange
Dim bottomCell As Range
Dim s
Dim y
Dim bottomCellminus As Long
Dim ws As Worksheet
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationManual
For Each ws In ActiveWorkbook.Worksheets
' Added: The next line will display which Worksheet is in progress
Application.StatusBar = "Working on:" & ws.Name & _
", which is number " & ws.Index & _
" out of " & ActiveWorkbook.Worksheets.Count & _
" Sheet(s)."
With ws
With .PageSetup
'.PrintTitleRows = "$3:$12"
.CenterHeader = "&A"
.CenterFooter = "Page &P of &N"
.LeftMargin = Application.InchesToPoints(0.694444444444444)
.RightMargin = Application.InchesToPoints(0.694444444444444)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0.25)
.FooterMargin = Application.InchesToPoints(0.25)
'.PrintHeadings = False
'.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLegal
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
'.FitToPagesWide = 1
'.FitToPagesTall = False
End With
Set bottomCell = .Range("C15").End(xlDown)
bottomCellminus = bottomCell.Row - 1
X = 15
Do While X <= bottomCell.Row
.Cells(X, 15) = "=SUM(C" & X & ":N" & X & ")"
.Cells(X, 17) = "=(+P" & X & "-O" & X & ")"
.Cells(X, 19) = "=(+R" & X & "-O" & X & ")"
' .Columns("B:S").Select
X = X + 1
Loop
' set totals formulas
bottomCell.Resize(, 17).FormulaR1C1 = "=SUM(R15C:R[-1]C)"
With .Columns("C:S")
.NumberFormat = "(#,###);[Red](#,###);_(* 0_)"
.EntireColumn.AutoFit
End With
' bottomCell = 0
bottomCellminus = 0
MName = .Name & ".xls"
MDir = ActiveWorkbook.Path
.Copy
With ActiveWorkbook
.SaveAs Filename:=MDir & "\" & MName
.Close False
End With
End With
Next ws
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False ' <-- Erases the bar & restores control to Excel.
End SubASKER
This one does work but my color scheme is specific so everything that I have in blue is coming out in red and green. Is there a way to use the specific color scheme when setting up the workbook?
That code copies each sheet, creating a new workbook with it. I don't see why the colours would change. Can you post a sample showing the problem?
ASKER
Here is a slide. The background color is coming up in red and green when the actual report is in a shade of blue.
test.xls
test.xls
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Perfect. I'll post another question shortly about creating a seperate ws within the newly saved one. Thanks for all your help!!
ASKER
Hi I'm sorry but I have one more question related to this. How can I protect the worksheet for the new worksheet?
ASKER
nevermind, I got it
Saurabh...
Open in new window