#1
|
|||
|
|||
5 Macros in One Document--Question
Hi all,
I have a document where I run 5 different macros--always in the same order. Just want to know if there is a way to automate the process, and run all of them at the same time. Thanks! |
#2
|
||||
|
||||
One simple way would be to insert a line with:
Call Macroname as the last line of the first four macros, where Macroname is the name of the next macro. Another way, which you allow you to continue running the independently if you wish is to create another macro like: Sub Main() Call Macro1 Call Macro2 Call Macro3 Call Macro4 Call Macro5 End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
Thank you for the macro. Put it all together and it is working perfectly.
Thanks, |
#4
|
||||
|
||||
Of course, it would also be possible to incorporate the code from all 5 macros into one. Without knowing what they are and the processing order, though, we can't really say what the best way of doing so would be.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
|||
|
|||
Here are the macros that I'm using. They are two files, one is called "Test #1", which is the original file before applying the macro, and Test # 2, which is the end result.
While processing the macros, a message box will come on so I have to hit enter, and for the message box, use number 112. Once the distribution of the numbers are done, there is a space between the question number and the question itself. See what I'm talking on test #2 that with your help, I would like with your help to put them together. Questions, please let me know. Thanks! Code:
Sub Main() Call SortQandA3 Call MatchQA Call MoveOneAnswer Call Macro1 Call FixMyExportedDocument2 Call EliminateMultipleSpaces Call ACCCCExcelSetOfQuestionNumbers Call ACCCCExcelMacroConvertingQuestionsToNumbers End Sub Sub SortQandA3() ' Sort questions and their answers so that they come in pairs. '''\ Set up general Find/Replace parameters. With Selection.Find .ClearFormatting .Replacement.ClearFormatting .Wrap = wdFindStop .Format = False .MatchCase = False .MatchWholeWord = False .MatchAllWordForms = False .MatchSoundsLike = False End With Application.ScreenUpdating = False Selection.HomeKey Unit:=wdStory Selection.TypeParagraph ' Ensure that we always start with one paragraph boundary for our search pattern. ' Force line-feeds to be paragraph boundaries. Selection.HomeKey Unit:=wdStory With Selection.Find .Text = "^l" .Replacement.Text = "^p" .Forward = True .MatchWildcards = False .Execute Replace:=wdReplaceAll End With ' Remove non-breaking spaces preceding paragraph markers. Selection.HomeKey Unit:=wdStory With Selection.Find .Text = "^s@^013" .Replacement.Text = "^p" .Forward = True .MatchWildcards = True .Execute Replace:=wdReplaceAll End With ' Match up questions with answers; exit if there is a mismatch. Selection.HomeKey Unit:=wdStory If Not MatchQA() Then Exit Sub ' Move each answer to follow its question. Dim i As Integer Selection.HomeKey Unit:=wdStory i = 0 Do While MoveOneAnswer() i = i + 1 Loop 'Exit Sub ' debug ' Remove answer headers, since they are redundant with question headers. Selection.HomeKey Unit:=wdStory With Selection.Find .Text = "(ANSWER: [A-D])[^013]@Question #[0-9]@[!^013]@[^013]" .Replacement.Text = "\1" .Forward = True .MatchWildcards = True .Execute Replace:=wdReplaceAll End With MsgBox "Processed " & i & " question/answer pairs.", , "DONE!" Application.ScreenUpdating = True End Sub Function MatchQA() As Boolean ' Make sure that every question has exactly one answer, and vice versa. Dim myQuestionHeader As String Dim myQuestionNumbers As String Dim myNumber As String Dim myMatchPosition As Integer Dim i As Integer Dim myContinueFlag As Boolean myQuestionNumbers = "" myContinueFlag = True ' Initialise the search parameters. With Selection.Find .Text = "[^013]Question #[0-9]@ " .Replacement.Text = "" .Forward = True .MatchWildcards = True End With ' Build a string of all the question and answer numbers. Do While myContinueFlag If Selection.Find.Execute Then myQuestionHeader = Selection.Text Selection.Collapse Direction:=wdCollapseEnd myQuestionNumbers = myQuestionNumbers & "<" & Mid(myQuestionHeader, 12, Len(myQuestionHeader) - 12) & ">" ' Put the question number within <> for easier parsing later. ' MsgBox "myQuestionHeader='" & myQuestionHeader & "'" & vbCrLf & "This number is>" & Mid(myQuestionHeader, 12, Len(myQuestionHeader) - 12) & "<", , "DEBUG" ' MsgBox "'" & myQuestionNumbers & "'", , "myQuestionNumbers DEBUG" Else myContinueFlag = False End If Loop ' Parse the question & answer number string this way: ' ' 1. Find the first number in the string. ' 2. Split the string with that first number as the delimiter. ' A. If there is exactly one match, we'll get an array of exactly 3 segments, ' the first of which is always empty. All okay. ' B. If there are more or fewer segments than 3, then we had an overmatch or undermatch. ' Exit with error! ' 3. Reassemble the segments into a fresh question and answer number string; it won't have the ' number that we just parsed out, so it's smaller now. ' 4. Repeat from step 1 as long as the length of the string is more than 1 (probably could check ' at 0, but just to be safe). ' myContinueFlag = True Do While Len(myQuestionNumbers) > 1 ' Dim mySegmentsMsg As String ' DEBUG Dim myQuestionNumberSegments() As String ' Array for the segments. myNumber = Left(myQuestionNumbers, InStr(1, myQuestionNumbers, ">")) ' Get the first number, including <> brackets. ' mySegmentsMsg = "myNumber='" & myNumber & "'" & vbCrLf & "myQuestionNumbers='" & myQuestionNumbers & "'" ' DEBUG ' MsgBox "myQuestionNumbers='" & myQuestionNumbers & "'" & vbCrLf & "myNumber='" & myNumber & "'", , "myNumber DEBUG" ' MsgBox "myNumber='" & myNumber & "'" & vbCrLf & "myQuestionNumbers='" & myQuestionNumbers & "'" ' DEBUG myQuestionNumberSegments = Split(myQuestionNumbers, myNumber) ' Split the string! ' Make sure we have 3 segments (we check against 2 because arrays count from zero). If UBound(myQuestionNumberSegments) < 2 Then MsgBox "Missing a match for question/answer #" & myNumber, , "ERROR!" myContinueFlag = False GoTo bye ElseIf UBound(myQuestionNumberSegments) > 2 Then MsgBox "Extra match(es) for question/answer #" & myNumber, , "ERROR!" myContinueFlag = False GoTo bye ' Else ' DEBUG ' MsgBox "myNumber=" & myNumber & vbCrLf & "myQuestionNumberSegments(0)='" & myQuestionNumberSegments(0) & "'" & vbCrLf & "myQuestionNumberSegments(1)='" & myQuestionNumberSegments(1) & "'" & vbCrLf & "myQuestionNumberSegments(2)='" & myQuestionNumberSegments(2) & "'", , UBound(myQuestionNumberSegments) ' DEBUG End If ' mySegmentsMsg = mySegmentsMsg & vbCrLf & "There are " & UBound(myQuestionNumberSegments) + 1 & " segments" ' DEBUG ' For i = 0 To UBound(myQuestionNumberSegments) ' mySegmentsMsg = mySegmentsMsg & vbCrLf & "'" & myQuestionNumberSegments(i) & "'" ' DEBUG ' Next myQuestionNumbers = "" For i = 0 To UBound(myQuestionNumberSegments) ' MsgBox "'" & myQuestionNumberSegments(i) & "'", , "myQuestionNumberSegments(" & i & ") DEBUG" myQuestionNumbers = myQuestionNumbers & myQuestionNumberSegments(i) ' MsgBox "'" & myQuestionNumbers & "'", , "myQuestionNumbers DEBUG" Next ' MsgBox "myNextNumber is <" & myNextNumber & ">", , "DEBUG" ' mySegmentsMsg = mySegmentsMsg & vbCrLf & "Now myQuestionNumbers='" & myQuestionNumbers & "'" ' DEBUG ' MsgBox mySegmentsMsg, , "mySegmentsMsg DEBUG" Loop bye: MatchQA = myContinueFlag ' Assign the boolean value to the name of the function, thus passing it to the calling subroutine. End Function Function MoveOneAnswer() As Boolean ' Match an answer to a question and move it to follow the question. Dim myQuestionHeader As String Dim myContinueFlag As Boolean ' First, find the lastmost answer. Selection.EndKey Unit:=wdStory With Selection.Find .Text = "[^013]Question #[0-9]@ " .Replacement.Text = "" .Forward = False .MatchWildcards = True .Execute End With ' Remember the question/answer number. myQuestionHeader = Selection.Text ' Get the correct answer letter. Selection.Collapse Direction:=wdCollapseStart Dim myCorrectAnswer As String With Selection.Find .Text = "[^013]([A-D]). \(Correct\!\)" .Replacement.Text = "" .Forward = True .MatchWildcards = True .Execute End With myCorrectAnswer = Selection.Text Selection.Collapse Direction:=wdCollapseStart myCorrectAnswer = Mid(myCorrectAnswer, 2, 1) ' MsgBox "mycorrectanswer is '" & myCorrectAnswer & "'", , "DEBUG" ' Go back up to the beginning of this answer. With Selection.Find .Text = myQuestionHeader .Replacement.Text = "" .Forward = False .MatchWildcards = False .Execute End With ' Grab the whole answer. Selection.Collapse Direction:=wdCollapseStart 'Selection.MoveUp Unit:=wdLine, Count:=1 Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.EndKey Unit:=wdStory, Extend:=wdExtend Selection.Cut ' Now find the matching question earlier in the file. With Selection.Find .Text = myQuestionHeader .Replacement.Text = "" .Forward = False .MatchWildcards = False .Execute End With ' Go to the top of the next question, which is also the bottom of the current question, and paste. With Selection.Find .Text = "[^013]Question #[0-9]@ " .Replacement.Text = "" .Forward = True .MatchWildcards = True End With If Selection.Find.Execute Then Selection.Collapse Direction:=wdCollapseStart Selection.TypeParagraph Selection.TypeText "ANSWER: " & myCorrectAnswer ' Insert the correct answer string too. Selection.TypeParagraph myContinueFlag = True Else ' Oops! We hit the end of file and are trying to process the final answer again. ActiveDocument.Undo ' Undo the last Cut... myContinueFlag = False ' ... and get out End If Selection.Paste ' MsgBox "myContinueFlag for " & myQuestionHeader & " is " & myContinueFlag, , "DEBUG" bye: MoveOneAnswer = myContinueFlag ' Assign the boolean value to the name of the function, thus passing it to the calling subroutine. End Function Sub Macro1() ' ' Macro1 Macro ' ' Selection.MoveDown Unit:=wdLine, Count:=7 Selection.Delete Unit:=wdCharacter, Count:=1 Selection.MoveDown Unit:=wdLine, Count:=1 Selection.Delete Unit:=wdCharacter, Count:=1 Selection.MoveDown Unit:=wdLine, Count:=1 Selection.Delete Unit:=wdCharacter, Count:=1 End Sub Sub ACCCCExcelMacroConvertingQuestionsToNumbers() ' ' MacropodMac1 Macro ' ' Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "[^013]Question #[0-9]@ " .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True End With Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "Question #([0-9]@) \(ACCCC.*\)" .Replacement.Text = "\1. " .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll End Sub Sub ACCCCExcelSetOfQuestionNumbers() Application.ScreenUpdating = False Dim i As Long i = CLng(InputBox("Starting#?")) With ActiveDocument.Range With .Find .ClearFormatting .Replacement.ClearFormatting .Text = "Question #([0-9]@) \(ACCCC*\)" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = False .MatchWildcards = True .Execute End With Do While .Find.Found .Text = Replace(.Text, Split(.Text, " ")(1), "#" & i) i = i + 1 .Collapse wdCollapseEnd .Find.Execute Loop End With Application.ScreenUpdating = True End Sub Sub FixMyExportedDocument2() Dim aPar As Paragraph For Each aPar In ActiveDocument.Paragraphs aPar.Format.FirstLineIndent = 0 If aPar.LeftIndent > 0 Then aPar.Alignment = wdAlignParagraphLeft Next aPar ActiveDocument.Content.Find.Execute FindText:="^t", ReplaceWith:=" ", Replace:=wdReplaceAll End Sub Sub EliminateMultipleSpaces() 'If something goes wrong, go to the errorhandler On Error GoTo ERRORHANDLER 'Checks the document for excessive spaces between words With Selection .HomeKey Unit:=wdStory With .Find .ClearFormatting .Replacement.ClearFormatting 'Here is where it is actually looking for spaces between words .Text = " [ ]@([! ])" 'This line tells it to replace the excessive spaces with one space .Replacement.Text = " \1" .MatchWildcards = True .Wrap = wdFindStop .Format = False .Forward = True 'execute the replace .Execute Replace:=wdReplaceAll End With With .Find 'This time its looking for excessive spaces after a paragraph mark .Text = "^p " 'What to replace it with .Replacement.Text = "^p" .MatchWildcards = False .Wrap = wdFindStop .Format = False .Forward = True 'Execute the replace .Execute Replace:=wdReplaceAll End With End With ERRORHANDLER: With Selection .ExtendMode = False .HomeKey Unit:=wdStory End With End Sub |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Document Property Question | ksigcajun | Word VBA | 9 | 10-14-2014 11:26 AM |
Advanced Master-Sub document question | MvdE | Word | 7 | 04-17-2014 05:42 AM |
Macro Needed to Insert Asnwer to A Question in Multiple Choice Format Question | rsrasc | Word VBA | 7 | 03-28-2014 12:28 PM |
Creating document from template but macros are still linked to template | webharvest | Word | 0 | 07-16-2011 09:34 AM |
Discover if Macros exist in template or document | jimbassett | Excel | 2 | 02-08-2010 08:06 AM |