Is it possible to streamline this code?

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

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,860
Office Version
  1. 2010
Platform
  1. Windows
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
 

ronnie76

Board Regular
Joined
Jul 26, 2007
Messages
101
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
Terrific! I will give it a try. Thank you so much, I really appreciate it.
 

Watch MrExcel Video

Forum statistics

Threads
1,133,244
Messages
5,657,583
Members
418,401
Latest member
B_A_M155

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
Top