• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 393
  • Last Modified:

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

Open in new window

0
rgagli1
Asked:
rgagli1
  • 7
  • 5
  • 2
1 Solution
 
Saurabh Singh TeotiaCommented:
Use this and it will do what you are looking for...
Saurabh...

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
ws.Select
 
' 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

Open in new window

0
 
Rory ArchibaldCommented:
I think this is what you are after?
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 Sub

Open in new window

0
 
rgagli1Author Commented:
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
0
Granular recovery for Microsoft Exchange

With Veeam Explorer for Microsoft Exchange you can choose the Exchange Servers and restore points you’re interested in, and Veeam Explorer will present the contents of those mailbox stores for browsing, searching and exporting.

 
Saurabh Singh TeotiaCommented:
Change line-7 which is this...
Dim bottomCellminus As Integer

to this...
Dim bottomCellminus As long
This would fix that...
0
 
Rory ArchibaldCommented:
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
0
 
rgagli1Author Commented:
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?
0
 
Rory ArchibaldCommented:
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 Sub

Open in new window

0
 
rgagli1Author Commented:
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?
0
 
Rory ArchibaldCommented:
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?
0
 
rgagli1Author Commented:
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
0
 
Rory ArchibaldCommented:
Does this work?
 

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
            for i = 1 to 56
               .colors(i) = thisworkbook.colors(i)
            next i
            .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 Sub 
Open in New Window Select All 

Open in new window

0
 
rgagli1Author Commented:
Perfect.  I'll post another question shortly about creating a seperate ws within the newly saved one.  Thanks for all your help!!
0
 
rgagli1Author Commented:
Hi I'm sorry but I have one more question related to this.  How can I protect the worksheet for the new worksheet?
0
 
rgagli1Author Commented:
nevermind, I got it
0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 7
  • 5
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now