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