Microsoft Office Forums

Go Back   Microsoft Office Forums > Microsoft Word > Word VBA

Reply
 
LinkBack Thread Tools Display Modes
  #1  
Old 10-31-2014, 02:09 AM
rsrasc rsrasc is offline Windows 7 64bit Office 2010 64bit
Competent Performer
 
Join Date: Mar 2014
Location: Germany
Posts: 113
rsrasc is on a distinguished road
Default 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!
Reply With Quote
  #2  
Old 10-31-2014, 02:39 AM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 18,033
macropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to behold
Default

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
[MS MVP - Word]
Reply With Quote
  #3  
Old 10-31-2014, 03:53 AM
rsrasc rsrasc is offline Windows 7 64bit Office 2010 64bit
Competent Performer
 
Join Date: Mar 2014
Location: Germany
Posts: 113
rsrasc is on a distinguished road
Default

Thank you for the macro. Put it all together and it is working perfectly.

Thanks,
Reply With Quote
  #4  
Old 10-31-2014, 04:23 AM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 18,033
macropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to behold
Default

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
[MS MVP - Word]
Reply With Quote
  #5  
Old 10-31-2014, 05:10 AM
rsrasc rsrasc is offline Windows 7 64bit Office 2010 64bit
Competent Performer
 
Join Date: Mar 2014
Location: Germany
Posts: 113
rsrasc is on a distinguished road
Default

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
Attached Files
File Type: docx Test 1-Without Modification.docx (18.9 KB, 1 views)
File Type: docx Test 2-End Result.docx (19.0 KB, 3 views)
Reply With Quote
Reply

Thread Tools
Display Modes


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


All times are GMT -7. The time now is 09:57 AM.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.
SEO by vBSEO ©2011, Crawlability, Inc.
MSOfficeForums.com is not affiliated with Microsoft