Is it possible to streamline this code?

R

ronnie76

Board Regular
Joined
Jul 26, 2007
Messages
101
I have several workbooks, which contain approximately 60 worksheets each. From time to time, the sheets need a mass update, so I wrote a macro to assist me with updating them. The code seems to work correctly, however it does run quite slow. I was wondering if anyone had some suggestions to help improve the efficiency.

Thanks in advance for any help or suggestions.


VBA Code: 
Sub Add_Formulas_and_Formatting_Protect_Sheets()
Dim wb As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim vFile As Variant

'Set source workbook
Set wb = ActiveWorkbook

'Open the target workbook
 vFile = Application.GetOpenFilename("Excel-files,*.xlsx", _
    1, "Select One File To Open", , False)

'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile

'Set selectedworkbook
Set wb2 = ActiveWorkbook




MsgBox wb2.Name

Application.ScreenUpdating = False


Set target_workbook = wb2
top:
pass = InputBox("password?")
repass = InputBox("Verify Password")
If Not (pass = repass) Then
MsgBox "you made a boo boo"
GoTo top
End If
For i = 1 To Worksheets.Count
If Worksheets(i).ProtectContents = True Then GoTo oops
Next
For Each rs In target_workbook.Worksheets
If rs.Name <> "Raw_Material_Data" Then


' Formatting Section

Sheets("Format Formula Template").Range("A1:BQ159").Copy
Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("A1").Select

' Formulas Section
rs.Activate
  Call Template_Section1
  Call Template_Section2
  Call Template_Section3


Else
End If
Next


Exit Sub
oops: MsgBox "I think you have some sheets that are already protected. Please unprotect all sheets then running this Macro."



Application.CutCopyMode = False
Application.ScreenUpdating = True

'wb2.Close

'Set targetworkbook
Set wb = ActiveWorkbook

End Sub

Snippet below is only a fraction of the actual code. Actual Cell Formulas Code is about 2300 lines long

Code: 
Sub Template_Section1()

Cells(1, 1).Formula = "Formula Number:"
Cells(1, 3).Formula = "Created By:"
Cells(1, 4).Formula = "v3.4"
Cells(2, 1).Formula = "Product Name:"
Cells(2, 4).Formula = "Comments:"
Cells(3, 1).Formula = "R&D Formula Version:"
Cells(3, 3).Formula = "Date:"
Cells(4, 1).Formula = "Printed:"
Cells(4, 2).Formula = "=NOW()"
Cells(5, 9).Formula = "Costing"
Cells(5, 12).Formula = "Formula Check"
Cells(5, 15).Formula = "Raw Material Specs"
Cells(5, 20).Formula = "Raw Material Nutritional Information"
Cells(5, 49).Formula = "Calculations - DO NOT EDIT!!!"
Cells(6, 1).Formula = "Raw Ingredient Supplier"
Cells(6, 2).Formula = "Raw Ingredient Number"
Cells(6, 3).Formula = "Raw Ingredients"
Cells(6, 5).Formula = "DENSITY"
Cells(6, 6).Formula = "% Use in Formula"
Cells(6, 7).Formula = "Liters"
Cells(6, 8).Formula = "Kg"
Cells(6, 9).Formula = "RI Cost"
Cells(6, 10).Formula = "MEANS"
Cells(6, 11).Formula = "Cost / L"
Cells(6, 12).Formula = "KG/1000 from Transferred"
Cells(6, 13).Formula = "Corrected % Use in Formula"
Cells(6, 14).Formula = "Free Column"
Cells(6, 15).Formula = "1/d"
Cells(6, 16).Formula = "Free Column"
Cells(6, 17).Formula = "RI Acid in g/l"
Cells(9, 1).Formula = "=LEFT(IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,35,FALSE)),20)"
Cells(9, 2).Formula = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,3,FALSE))"
Cells(9, 3).Formula = "=LEFT(IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,2,FALSE)),30)"
Cells(9, 5).Formula = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,4,FALSE))"
Cells(9, 6).Formula = "=IF(D9="""","""",IF(ISERROR(MATCH(D9,N33:N51,0)),""Manual Entry"",G9/$G$7*100))"
Cells(9, 7).Formula = "=IF(D9="""","""",IF(ISERROR(MATCH(D9,N33:N51,0)),F9*10*$G$7/1000,H9/E9))"
Cells(9, 8).Formula = "=IF(D9="""","""",IF(ISNA(MATCH(D9,N33:N51,0)),ROUND((G9*E9),5),ROUND(($B$38/B40*100*G7/1000),5)))"
Cells(9, 9).Formula = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,7,FALSE))"
Cells(9, 10).Formula = "=IF(ISBLANK($D9),"""",(H9*I9))"
Cells(9, 11).Formula = "=SUM(J9:J27,)/G7"
Cells(9, 13).Formula = "=IF(ISBLANK(D9),"""",IF(ROUND(L9,5)=H9,"""",L9/H9*F9))"
Cells(9, 15).Formula = "=IF(ISBLANK($D9),"""",1/E9)"
Cells(9, 17).Formula = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,6,FALSE))"
Cells(9, 18).Formula = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,5,FALSE))"
Cells(9, 19).Formula = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,41,FALSE))"
Cells(9, 20).Formula = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,11,FALSE))"

End Sub
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
Sort by date Sort by votes
you are writing to the worksheet quite a lot of times. if you reduce this it will speed things up. Writing an array out to a worksheet is almost as fast as writing a single cell. So I have rewritten your temmplate section1 code to reduce the number of writes from 65 to 7:
VBA Code: 
Sub Template_Section1_vr()
Dim A1toD4(1 To 4, 1 To 4)
A1toD4(1, 1) = "Formula Number:"
A1toD4(1, 3) = "Created By:"
A1toD4(1, 4) = "v3.4"
A1toD4(2, 1) = "Product Name:"
A1toD4(2, 4) = "Comments:"
A1toD4(3, 1) = "R&D Formula Version:"
A1toD4(3, 3) = "Date:"
A1toD4(4, 1) = "Printed:"
A1toD4(4, 2) = "=NOW()"
Range("a1:D4").Formula = A1toD4

Cells(5, 9) = "Costing"
Cells(5, 12) = "Formula Check"
Cells(5, 15) = "Raw Material Specs"
Cells(5, 20) = "Raw Material Nutritional Information"
Cells(5, 49) = "Calculations - DO NOT EDIT!!!"

Dim A6toQ6(1 To 1, 1 To 17)
A6toQ6(1, 1) = "Raw Ingredient Supplier"
A6toQ6(1, 2) = "Raw Ingredient Number"
A6toQ6(1, 3) = "Raw Ingredients"
A6toQ6(1, 5) = "DENSITY"
A6toQ6(1, 6) = "% Use in Formula"
A6toQ6(1, 7) = "Liters"
A6toQ6(1, 8) = "Kg"
A6toQ6(1, 9) = "RI Cost"
A6toQ6(1, 10) = "MEANS"
A6toQ6(1, 11) = "Cost / L"
A6toQ6(1, 12) = "KG/1000 from Transferred"
A6toQ6(1, 13) = "Corrected % Use in Formula"
A6toQ6(1, 14) = "Free Column"
A6toQ6(1, 15) = "1/d"
A6toQ6(1, 16) = "Free Column"
A6toQ6(1, 17) = "RI Acid in g/l"
Range("A6:Q6").Formula = A6toQ6

Dim A9toT9(1 To 1, 1 To 20)
A9toT9(1, 1) = "=LEFT(IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,35,FALSE)),20)"
A9toT9(1, 2) = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,3,FALSE))"
A9toT9(1, 3) = "=LEFT(IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,2,FALSE)),30)"
A9toT9(1, 5) = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,4,FALSE))"
A9toT9(1, 6) = "=IF(D9="""","""",IF(ISERROR(MATCH(D9,N33:N51,0)),""Manual Entry"",G9/$G$7*100))"
A9toT9(1, 7) = "=IF(D9="""","""",IF(ISERROR(MATCH(D9,N33:N51,0)),F9*10*$G$7/1000,H9/E9))"
A9toT9(1, 8) = "=IF(D9="""","""",IF(ISNA(MATCH(D9,N33:N51,0)),ROUND((G9*E9),5),ROUND(($B$38/B40*100*G7/1000),5)))"
A9toT9(1, 9) = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,7,FALSE))"
A9toT9(1, 10) = "=IF(ISBLANK($D9),"""",(H9*I9))"
A9toT9(1, 11) = "=SUM(J9:J27,)/G7"
A9toT9(1, 13) = "=IF(ISBLANK(D9),"""",IF(ROUND(L9,5)=H9,"""",L9/H9*F9))"
A9toT9(1, 15) = "=IF(ISBLANK($D9),"""",1/E9)"
A9toT9(1, 17) = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,6,FALSE))"
A9toT9(1, 18) = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,5,FALSE))"
A9toT9(1, 19) = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,41,FALSE))"
A9toT9(1, 20) = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,11,FALSE))"
Range("A9:T9").Formula = A9toT9

End Sub
If you have nothing else on the worksheet then you can reduce it to one write by using one large variant array
 
Upvote 0
offthelip said:
you are writing to the worksheet quite a lot of times. if you reduce this it will speed things up. Writing an array out to a worksheet is almost as fast as writing a single cell. So I have rewritten your temmplate section1 code to reduce the number of writes from 65 to 7:
VBA Code: 
Sub Template_Section1_vr()
Dim A1toD4(1 To 4, 1 To 4)
A1toD4(1, 1) = "Formula Number:"
A1toD4(1, 3) = "Created By:"
A1toD4(1, 4) = "v3.4"
A1toD4(2, 1) = "Product Name:"
A1toD4(2, 4) = "Comments:"
A1toD4(3, 1) = "R&D Formula Version:"
A1toD4(3, 3) = "Date:"
A1toD4(4, 1) = "Printed:"
A1toD4(4, 2) = "=NOW()"
Range("a1:D4").Formula = A1toD4

Cells(5, 9) = "Costing"
Cells(5, 12) = "Formula Check"
Cells(5, 15) = "Raw Material Specs"
Cells(5, 20) = "Raw Material Nutritional Information"
Cells(5, 49) = "Calculations - DO NOT EDIT!!!"

Dim A6toQ6(1 To 1, 1 To 17)
A6toQ6(1, 1) = "Raw Ingredient Supplier"
A6toQ6(1, 2) = "Raw Ingredient Number"
A6toQ6(1, 3) = "Raw Ingredients"
A6toQ6(1, 5) = "DENSITY"
A6toQ6(1, 6) = "% Use in Formula"
A6toQ6(1, 7) = "Liters"
A6toQ6(1, 8) = "Kg"
A6toQ6(1, 9) = "RI Cost"
A6toQ6(1, 10) = "MEANS"
A6toQ6(1, 11) = "Cost / L"
A6toQ6(1, 12) = "KG/1000 from Transferred"
A6toQ6(1, 13) = "Corrected % Use in Formula"
A6toQ6(1, 14) = "Free Column"
A6toQ6(1, 15) = "1/d"
A6toQ6(1, 16) = "Free Column"
A6toQ6(1, 17) = "RI Acid in g/l"
Range("A6:Q6").Formula = A6toQ6

Dim A9toT9(1 To 1, 1 To 20)
A9toT9(1, 1) = "=LEFT(IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,35,FALSE)),20)"
A9toT9(1, 2) = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,3,FALSE))"
A9toT9(1, 3) = "=LEFT(IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,2,FALSE)),30)"
A9toT9(1, 5) = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,4,FALSE))"
A9toT9(1, 6) = "=IF(D9="""","""",IF(ISERROR(MATCH(D9,N33:N51,0)),""Manual Entry"",G9/$G$7*100))"
A9toT9(1, 7) = "=IF(D9="""","""",IF(ISERROR(MATCH(D9,N33:N51,0)),F9*10*$G$7/1000,H9/E9))"
A9toT9(1, 8) = "=IF(D9="""","""",IF(ISNA(MATCH(D9,N33:N51,0)),ROUND((G9*E9),5),ROUND(($B$38/B40*100*G7/1000),5)))"
A9toT9(1, 9) = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,7,FALSE))"
A9toT9(1, 10) = "=IF(ISBLANK($D9),"""",(H9*I9))"
A9toT9(1, 11) = "=SUM(J9:J27,)/G7"
A9toT9(1, 13) = "=IF(ISBLANK(D9),"""",IF(ROUND(L9,5)=H9,"""",L9/H9*F9))"
A9toT9(1, 15) = "=IF(ISBLANK($D9),"""",1/E9)"
A9toT9(1, 17) = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,6,FALSE))"
A9toT9(1, 18) = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,5,FALSE))"
A9toT9(1, 19) = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,41,FALSE))"
A9toT9(1, 20) = "=IF(ISBLANK($D9),"""",VLOOKUP($D9,Raw_Material_Data!$A:$AY,11,FALSE))"
Range("A9:T9").Formula = A9toT9

End Sub
Click to expand...
Terrific! I will give it a try. Thank you so much, I really appreciate it.
 
Upvote 0
You must log in or register to reply here.

Similar threads

Guna13
  • Question
How to Efficient way for create Multiple Workbooks
Replies
1
Views
90
Guna13
Guna13
montecarlo2012
  • Question
read sheet 1 display on sheet 7 (Phytagoras)
Replies
5
Views
280
bebo021999
B
D
  • Question
"Disabling" calculation of certain formulas until source cells updated -- is there a better way to do this?
Replies
0
Views
451
d0rian
D
gallen
  • Question
Macro Enabled Workbooks Suddenly Corrupting Regularly.
Replies
5
Views
953
Joe4
Joe4
B
  • Question
Looking for advice: Methods to update a table from a data source stored online
Replies
0
Views
248
blothian
B

Forum statistics

Threads
1,214,653
Messages
6,120,750
Members
448,989
Latest member
mariah3

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top