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