need help with macro for 400 worksheets!

F

flyers2thecup

I need to change the formatting, enter a few simple math formulas, an
password protect 400 documents. What I'm trying to accomlish is to b
able to run the macro for all the documents without having to open eac
one and perform the macro. i'll have all of them saved in on
directory.

the other issue is although each file will have the exact same amout o
columns, the amount of rows will not always be the same. And I need t
have a couple SUM formulas after the last row of each worksheet.

here is the vba code of the macro.

If there is any more explanation needed, please let me know.

I'm under pressure here at work to try and get this done...the previou
employee left on short notice and now i'm cleaning up the pieces. fun!


Thanks in advance for any guideance!



Code
-------------------
Sub Merit01()
'
' Merit01 Macro
' Macro recorded 4/4/2006 by xsxf8cq
'
' Keyboard Shortcut: Ctrl+Shift+M
'
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.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 = 100
End With
Columns("D:D").Select
Selection.NumberFormat = "#,##0.00"
Columns("H:H").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
Columns("L:L").Select
Selection.NumberFormat = "#,##0.00"
ActiveWindow.LargeScroll ToRight:=1
Range("Q:Q,S:S").Select
Range("S1").Activate
Selection.NumberFormat = "#,##0.00"
Columns("R:R").Select
Selection.NumberFormat = "0.00"
Range("R2").Select
ActiveCell.FormulaR1C1 = "=(RC[-1]/RC[-14])*100"
Range("R3").Select
ActiveWindow.SmallScroll ToRight:=6
Range("R2").Select
Selection.Copy
Range("R3:R29").Select
ActiveSheet.Paste
ActiveWindow.LargeScroll ToRight:=-1
Range("D29").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=SUM(R[-27]C:R[-1]C)"
Range("D30").Select
ActiveWindow.LargeScroll ToRight:=1
Range("Q29").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-27]C:R[-1]C)"
Range("S2").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-2],RC[-15])"
Range("S2").Select
Selection.Copy
Range("S3:S28").Select
ActiveSheet.Paste
Cells.Select
Range("E1").Activate
Selection.Columns.AutoFit
ActiveWindow.LargeScroll ToRight:=-1
Range("A1").Select
Application.CutCopyMode = False
ActiveWorkbook.Protect Structure:=True, Windows:=False
End Su
 
P

PY & Associates

We suggest you try looping through the files using Dir( ) and call Merit01
within the loop thus

get first filename - dir()
start of loop
open first file
call Merit01
close activeworkbook
get next filename - dir
loop back

the last blank cell for the formula for column D would be
cells(rows.count,4).end(xlup)(2)

Regards

"flyers2thecup" <[email protected]>
wrote in message
I need to change the formatting, enter a few simple math formulas, and
password protect 400 documents. What I'm trying to accomlish is to be
able to run the macro for all the documents without having to open each
one and perform the macro. i'll have all of them saved in one
directory.

the other issue is although each file will have the exact same amout of
columns, the amount of rows will not always be the same. And I need to
have a couple SUM formulas after the last row of each worksheet.

here is the vba code of the macro.

If there is any more explanation needed, please let me know.

I'm under pressure here at work to try and get this done...the previous
employee left on short notice and now i'm cleaning up the pieces. fun!


Thanks in advance for any guideance!



Code:
--------------------
Sub Merit01()
'
' Merit01 Macro
' Macro recorded 4/4/2006 by xsxf8cq
'
' Keyboard Shortcut: Ctrl+Shift+M
'
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.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 = 100
End With
Columns("D:D").Select
Selection.NumberFormat = "#,##0.00"
Columns("H:H").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
Columns("L:L").Select
Selection.NumberFormat = "#,##0.00"
ActiveWindow.LargeScroll ToRight:=1
Range("Q:Q,S:S").Select
Range("S1").Activate
Selection.NumberFormat = "#,##0.00"
Columns("R:R").Select
Selection.NumberFormat = "0.00"
Range("R2").Select
ActiveCell.FormulaR1C1 = "=(RC[-1]/RC[-14])*100"
Range("R3").Select
ActiveWindow.SmallScroll ToRight:=6
Range("R2").Select
Selection.Copy
Range("R3:R29").Select
ActiveSheet.Paste
ActiveWindow.LargeScroll ToRight:=-1
Range("D29").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=SUM(R[-27]C:R[-1]C)"
Range("D30").Select
ActiveWindow.LargeScroll ToRight:=1
Range("Q29").Select
ActiveCell.FormulaR1C1 = "=SUM(R[-27]C:R[-1]C)"
Range("S2").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-2],RC[-15])"
Range("S2").Select
Selection.Copy
Range("S3:S28").Select
ActiveSheet.Paste
Cells.Select
Range("E1").Activate
Selection.Columns.AutoFit
ActiveWindow.LargeScroll ToRight:=-1
Range("A1").Select
Application.CutCopyMode = False
ActiveWorkbook.Protect Structure:=True, Windows:=False
End Sub
Click to expand...
 
B

broro183

Hi

I agree with PY & Associates that looping through the files is the way
to go & the suggestion for identifying the last row.

I've made some changes to your macro which should speed it up (based on
the fact that the fewer dots used the better) & have added some
explanatory comments with a prefix of "'*":


Code:
--------------------
Sub Merit01()
' Keyboard Shortcut: Ctrl+Shift+M
Application.ScreenUpdating = False
Dim LastRow As Long
'*same concept as other post but uses column A to find last row
LastRow = Cells(rows.Count, "A").End(xlUp).Row

'* have left the page setup code as I'm not sure which lines are actually _
needed. FYI, any lines that are the default values should be safe to delete.
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.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 = 100
End With
'* have limited to this range to help keep file size down.
Range("D1:D" & LastRow & ",L1:L" & LastRow & ",Q1:Q" & LastRow & ",S1:S" & LastRow).NumberFormat = "#,##0.00"

With Range("H1:H" & LastRow)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
With Range("R2:r" & LastRow)
.NumberFormat = "0.00"
.FormulaR1C1 = "=(RC[-1]/RC[-14])*100"
End With
'* my setting for range may need to be adjusted?
Range("D" & LastRow + 1 & ",Q" & LastRow + 1).FormulaR1C1 = "=SUM(R[-" & LastRow - 1 & "]C:R[-1]C)"
Range("S2:s" & LastRow).FormulaR1C1 = "=SUM(RC[-2],RC[-15])"
Cells.columns.AutoFit
Range("A1").Select
'I've added a password to the following code - on off chance it is wanted.
ActiveWorkbook.Protect Structure:=True, Windows:=False, Password:="secret"
'* may be best if the screen updating is turned on at the end of the _
"looping macro" rather than here.
Application.ScreenUpdating = True

End Sub
--------------------


Test this on a copy of a file first before unleashing it & good luck
with the 400 files :)

hth
Rob Brockett
NZ
Always learning & the best way to learn is to experience...
 

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

Different Results from the Same Macro 3
variable number of rows. 3
Creating Pivot Table with Macro using Multiple Sheets 0
Copying Data Down the Column But Only Based on What's in Column A 3
works in 2007 but not in 2010 0
Totals An Easier Way?? 5
Page Setup not working in macro 1
Help merging two VBA codes 2

Top