Solved: Execute multiple subs or one large sub

[rob0923]

Hi,

This may be bit of a basic question, but if you are writing a program to do several different things, such as create dirs, push values from excel to word, save the files and create a pdf from word. Would you create four seperate subs? If so how would you run all of them without manually going to each one, or would you write one large one?

Thanks,

[mdmackillop]

Your macros need to work and to be maintainable. This is easier if they are not too lengthy. Splitting up a large routine to a series of smaller tasks means you can test and debug individually. If you need to make changes, the consequences are easier to follow. You can easily call a series of macros from one main code. eg

Sub Main()
Call Macro1
Call Macro2
Call Macro3
End Sub

As shown in the Folders question (http://vbaexpress.com/forum/showpost.php?p=189529&postcount=2), you can pass parameters to another macro to carry out repeated tasks. If you need to return a value, then use a Function eg


Sub Test
Msgbox MyValue(2)
End Sub

Function MyValue(x as long)
MyValue = x^3
End Function

[Bob Phillips]

Plus you can spread the procedures over multiple code modules.

[rob0923]

I noticed with the sub using arrays "DoMkDir sub" did not show on the macro list. I guess I have alot to learn! What did you mean by spread procedures over multiple code modules?

[mdmackillop]

I noticed with the sub using arrays "DoMkDir sub" did not show on the macro list. I guess I have alot to learn! What did you mean by spread procedures over multiple code modules?
If you create several single purpose formatting macros, eg Adding borders, colours, fonts etc., then organize them in one module named for example modFormatting. Functions could go in another, Sorting/Filtering in others and so on.

A macro which requires a parameter does not appear in the macro list. It cannot be run from a shortcut or button as it needs another procedure to provide the parameter.

Don't worry about having a lot to learn. The more you do, the more you find that there is still even more!

[rob0923]

I'll get the hang of it once I do something that requires something like that. I still have a few more steps in the program I am writing that I am not too sure how to do yet, but for example. If I push excel to word in the first sub (eg - Sub pushtoword) and end that sub the next sub I want to save the word file (eg - Private Sub saveasworddoc)

Is there any way to make the Objects that were dimmed. Such as, ("Word.Application") in the first sub to transfer to the next sub, This would be to save the Word.ActiveDocument that was created in the first Sub.

[mdmackillop]

Can you post your code as it is now, or a sample workbook?

[rob0923]

As you will notice I have dim appWrd and dim objDoc twice because I ended the sub and I was getting an error that it was not specified in the next sub. However I am not sure in the second sub that I am making a new word doc rahter then trying to save the existing word active word document

I do have other subs in between these (create directories, that you helped me with) but thought I'd keep it out to keep the code size down a bit.


Option Explicit

Public Sub MergetoTemplate()


Dim appWrd As Object
Dim objDoc As Object
Dim FilePath As String
Dim FileName As String
Dim appExl As Excel.Workbook
Dim ExlNm As Excel.Name
Dim NmSaveper As Range


'Start Push Excel to Word

'Turn some stuff off while macro is running
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False

'Assign the word file path and name to
FilePath = ThisWorkbook.Path & "\Template"
FileName = "Sales_Temp.doc"

'Set instance of active workbook
Set appExl = ActiveWorkbook

'Open specified Word File
Set appWrd = CreateObject("Word.Application")

'Open specified word file, and Error if File cannot be found
On Error Resume Next
Set objDoc = appWrd.Documents.Add(FilePath & "\" & FileName)

'Error Handling
If objDoc Is Nothing Then
MsgBox "Unable to find the Word file", vbCritical, "File Not Found"
appWrd.Quit
Set appWrd = Nothing
Exit Sub
End If

'Loop through names in the Workbook
For Each ExlNm In appExl.Names

'Place into bookmark if Excel name match Word bookmark
If objDoc.Bookmarks.Exists(ExlNm.Name) Then
objDoc.Bookmarks(ExlNm.Name).Range.Text = Format(Range(ExlNm.Value), "$#,##0.00")
End If
Next ExlNm


'Set Excel ranges for paste into bookmarks
Set NmSaveper = Worksheets("Sheet1").Range("B4")

'Set NumberFormat for Excel ranges other then "$#,##0.00"
With objDoc.Bookmarks
.Item("NmSave").Range.InsertAfter Format((NmSaveper.Value), "#%")
End With

'Turn some stuff back on
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True

'Display word
appWrd.Visible = True

Call SaveWord

End Sub


Private Sub SaveWord()

'Save Word
Dim NmComp
Dim WrdPth As String
Dim appWrd As Object
Dim TodayDate As String
Dim objDoc As Object


Set appWrd = GetObject(, "Word.Application")

'Set Active document
Set WordDoc = Word.ActiveDocument

'Company Value
NmComp = Worksheets("Sheet1").Range("B1")

'Get date for file string
TodayDate = Format(Date, "mm.dd.yyyy")

'Set Path
WrdPth = ThisWorkbook.Path & "\" & NmComp & "_" & TodayDate & "\Word"

'Save file
objDoc.SaveAs WrdPth & "\" & NmComp & "_" & TodayDate & ".doc"

'Quit
applWrd.Quit


End Sub

[Bob Phillips]

One way



Public Sub WordControl()
Dim appWrd As Object

'Turn some stuff off while macro is running
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False

'Open specified Word File
Set appWrd = CreateObject("Word.Application")

If MergetoTemplate(appWrd) Then

'only continue if last function completed okay

'Turn some stuff back on
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True

'Display word
appWrd.Visible = True

Call SaveWord(appWrd)
End If

appWrd.Quit
Set appWrd = Nothing

End Sub

Public Function MergetoTemplate(ByRef WordApp As Object) As Boolean
Dim objDoc As Object
Dim FilePath As String
Dim FileName As String
Dim appExl As Excel.Workbook
Dim ExlNm As Excel.Name
Dim NmSaveper As Range

'Start Push Excel to Word

'Assign the word file path and name to
FilePath = ThisWorkbook.Path & "\Template"
FileName = "Sales_Temp.doc"

'Set instance of active workbook
Set appExl = ActiveWorkbook

'Open specified word file, and Error if File cannot be found
On Error Resume Next
Set objDoc = WordApp.Documents.Add(FilePath & "\" & FileName)

'Error Handling
If objDoc Is Nothing Then
MsgBox "Unable to find the Word file", vbCritical, "File Not Found"
MergetoTemplate = False
End If

'Loop through names in the Workbook
For Each ExlNm In appExl.Names

'Place into bookmark if Excel name match Word bookmark
If objDoc.Bookmarks.Exists(ExlNm.Name) Then
objDoc.Bookmarks(ExlNm.Name).Range.Text = Format(Range(ExlNm.Value), "$#,##0.00")
End If
Next ExlNm


'Set Excel ranges for paste into bookmarks
Set NmSaveper = Worksheets("Sheet1").Range("B4")

'Set NumberFormat for Excel ranges other then "$#,##0.00"
With objDoc.Bookmarks
.Item("NmSave").Range.InsertAfter Format((NmSaveper.Value), "#%")
End With

MergetoTemplate = True

End Function

Private Function SaveWord(ByRef WordApp As Object) As Boolean

Dim NmComp
Dim WrdPth As String
Dim TodayDate As String
Dim objDoc As Object

'Set Active document
Set objDoc = WordApp.ActiveDocument

'Company Value
NmComp = Worksheets("Sheet1").Range("B1")

'Get date for file string
TodayDate = Format(Date, "mm.dd.yyyy")

'Set Path
WrdPth = ThisWorkbook.Path & "\" & NmComp & "_" & TodayDate & "\Word"

'Save file
objDoc.SaveAs WrdPth & "\" & NmComp & "_" & TodayDate & ".doc"

End Function

[mdmackillop]

A small point to using dates in file names; if you need to sort/list them by date in the Explorer window, then consider using

TodayDate = Format(Date, "yyyy.mm.dd")

[rob0923]

I will test this out when I get on a PC. I am assuming I can use a private function to Save the Excel document as well (It will have a protection on it too) and then last I need to make word to a pdf and save the pdf, but I think I'll do one thing at a time.

i am assuming that I will need to call a word macro to print with pdfcreator.
Thanks for all your quick replies!

[rob0923]

Thanks for all your help! This is working great. You are definatly masters at this! :) I will attempt to create a pdf out of the word doc now..

Thanks again!

[rob0923]

Hi,

Another question regarding this vba. When I want to set up an Error Handler. For example once the VBA has transfered the data using the private function as xld used above.

How would I set up an Error Handler so it goes to another sub and will kill the vba without proceeding to ever called sub after an error has been found. I possible would like it to close the word application down and delete any files/directories have been created.

I have tried

On Error Goto Err1
Exit Function

Err1:
Call Error1

Private Sub Error1()
Msg Box = ""
End Sub

However it will still return to the main sub and continue the main trying to create directories and pdf the document, but will create a debug error.

Thanks in advance

[Bob Phillips]

If you add an error handler in the top level module, and don't re-issue an On Error at any later point, the original error handler will still be operational in the called procedures, so any error there will be directed back to the top module error handler. Here you can do any tidying up needed, probably best to use


Err1:

On Error Resum Next
'delete any files required
Exit Sub


If you only have the information to know what to tidy up in the called procedures, it is more complex. In this case, it is best to set an erro handler in each, and pass control back up the chain, testing for success as you go.

Something like this



Option Explicit

Public ErrMsg As String

Public Function TopLevel()

On Error GoTo Top_Error

ErrMsg = ""

'do some stuff

If Not SecondLevel_1 Then Err.Raise 99999

'do some more stuff

If Not SecondLevel_2 Then Err.Raise 99999

Exit Function

Top_Error:

MsgBox "An unexpected error has occurred" & vbNewLine & vbNewLine & ErrMsg, vbOKOnly + vbCritical, "My App"
End Function

Private Function SecondLevel_1() As Boolean

On Error GoTo S1_Error

SecondLevel_1 = True

'do some stuff
MkDir "C:\secondlevel_1" '<<<< just for testing
MsgBox "SecondLevel_1" '<<<< just for testing

S1_Exit:
'any tidy-up code whether successful or not goes here
Exit Function

S1_Error:
SecondLevel_1 = False
If ErrMsg = "" Then ErrMsg = _
"Error " & Err.Number & " - " & Err.Description & vbNewLine & vbNewLine & _
"SecondLevel_1"
Call Tidyup
Resume S1_Exit
End Function

Private Function SecondLevel_2() As Boolean

On Error GoTo S2_Error

SecondLevel_2 = True

'do some stuff
If Not ThirdLevel_1 Then Err.Raise 99999

S2_Exit:
'any tidy-up code whether successful or not goes here
Exit Function

S2_Error:
SecondLevel_2 = False
If ErrMsg = "" Then ErrMsg = _
"Error " & Err.Number & " " & Err.Description & vbNewLine & vbNewLine & _
"SecondLevel_2"
Call Tidyup
Resume S2_Exit
End Function

Private Function ThirdLevel_1() As Boolean

On Error GoTo T1_Error

ThirdLevel_1 = True

'do some stuff
Debug.Print 1 / 0 '<<<< force an error

T1_Exit:
'any tidy-up code whether successful or not goes here
Exit Function

T1_Error:
ThirdLevel_1 = False
If ErrMsg = "" Then ErrMsg = _
"Error " & Err.Number & " - " & Err.Description & vbNewLine & vbNewLine & _
"ThirdLevel_1"
Call Tidyup
Resume T1_Exit
End Function

Private Function Tidyup()

'add any tidy-up code that you could on failure need here
On Error Resume Next
RmDir "C:\secondlevel_1"
RmDir "C:\secondlevel_2"
End Function

[rob0923]

Thanks for the quick responce. Just to mae sure I have this correct.
The code would be something like below. There are more steps, but I took some functions out due to the size.

Perferably if it come up with an error creating the directories theres no need to try to save anything and just by pass the remainder of the functions. Or if C10 is empty which is required to create the directories is empty a box pops up requiring them to enter something for C10.




Option Explicit
Public ErrMsg As String

Public Function CreateReport()
Dim appWrd As Object
Dim appExl As Object

On Error GoTo Top_Error
ErrMsg = ""

'Turn some stuff off while macro is running
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False

'Set instance for Word
Set appWrd = CreateObject("Word.Application")

'Set instance for Excel
Set appExl = Excel.Application


If MergetoTemplate(appWrd) Then

'only continue if last function completed okay

'Turn some stuff back on
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True

'Display word
appWrd.Visible = True

'Call sub to create dir's
If Not Createdir() Then Err.Raise 99999

'Call SaveWord
'Call SaveWord(appWrd)

End If

Set appExl = Nothing
Set appWrd = Nothing

Top_Error:
MsgBox "An unexpected error has occurred" & vbNewLine & vbNewLine & ErrMsg, vbOKOnly + vbCritical, "My App"

appWrd.Quit

Set appExl = Nothing
Set appWrd = Nothing

End Function

Public Function MergetoTemplate(ByRef Wordapp As Object) As Boolean
Dim objDoc As Object
Dim FilePath As String
Dim FileName As String
Dim ExlNm As Excel.Name
Dim NmSaveper As Range
Dim exlWbk As Excel.Workbook

'Start Push Excel to Word

'Assign the word file path and name to
FilePath = ThisWorkbook.Path & "\Template"
FileName = "Sales_Temp.doc"

'Set instance of active workbook
Set exlWbk = ActiveWorkbook

'Open specified word file, and Error if File cannot be found
On Error Resume Next
Set objDoc = Wordapp.Documents.Add(FilePath & "\" & FileName)

'Error Handling
If objDoc Is Nothing Then
MsgBox "Unable to find the Word file", vbCritical, "File Not Found"
MergetoTemplate = False
End If

'Loop through names in the Workbook
For Each ExlNm In exlWbk.Names

'Place into bookmark if Excel name match Word bookmark
If objDoc.Bookmarks.Exists(ExlNm.Name) Then
objDoc.Bookmarks(ExlNm.Name).Range.Text = Format(Range(ExlNm.Value), "$#,##0.00")
End If
Next ExlNm


'Set Excel ranges for paste into bookmarks
Set NmSaveper = Worksheets("Sheet1").Range("B4")

'Set NumberFormat for Excel ranges other then "$#,##0.00"
With objDoc.Bookmarks
.Item("NmSave").Range.InsertAfter Format((NmSaveper.Value), "#%")
End With

MergetoTemplate = True

Set objDoc = Nothing

End Function

Private Function SaveWord(ByRef Wordapp As Object) As Boolean

Dim NmComp
Dim WrdPth As String
Dim TodayDate As String
Dim objDoc As Object

'Set Active document
Set objDoc = Wordapp.ActiveDocument

'Company Value
NmComp = Worksheets("Cover Sheet").Range("C10")

'Get date for file string
TodayDate = Format(Date, "yyyy.mm.dd")

'Set Path
WrdPth = ThisWorkbook.Path & "\Saved_Quotes" & "\" & NmComp & "_" & TodayDate & "\Word"

'Save file
objDoc.SaveAs WrdPth & "\" & NmComp & "_" & TodayDate & ".doc"

Set objDoc = Nothing

End Function

Private Function Createdir() As Boolean

'Set Directories for Company.Value
Dim NmComp
Dim msg As Long 'Inform user message
Dim TodayDate As String
Dim TopDirectory As String
Dim MainDirectory As String

'First check if value in B1
If Worksheets("Cover Sheet").Range("C10") <> "" Then
'Yes
NmComp = Worksheets("Cover Sheet").Range("C10")
Else

'No value in "C10"
On Error GoTo Createdir_Err
End If

Createdir = True

'Get date for Dir string
TodayDate = Format(Date, "yyyy.mm.dd")

'Build Main directory string
MainDirectory = ThisWorkbook.Path & "\Saved_Quotes"

'Build top directory string
TopDirectory = ThisWorkbook.Path & "\Saved_Quotes" & "\" & NmComp & "_" & TodayDate

'Check Main Dir
If Dir(MainDirectory, vbDirectory) = "" Then
MkDir MainDirectory
End If

'Check parent. No parent, no kids.
If Dir(TopDirectory, vbDirectory) = "" Then
'Doesn't exist. Create it and all subdirectories
MkDir TopDirectory
End If

S1_Exit:
'any tidy-up code whether successful or not goes here
Exit Function

Createdir_Err:
Createdir = False
If ErrMsg = "" Then ErrMsg = _
"Error " & Err.Number & " - " & Err.Description & vbNewLine & vbNewLine & _
"Create Directories"
Call Tidyup
Resume S1_Exit

End Function

Private Function Tidyup()
'add any tidy-up code that you could on failure need here

On Error Resume Next
RmDir "C:\secondlevel_1"
RmDir "C:\secondlevel_2"
End Function