I'm trying to go through a MSWord document and pull out all the paragraphs with the Style, "Question" and then reprint them at the end of the document. Any suggestions would be super helpful - here's what I have (I think all the steps are there I'm just having trouble with VBA formatting).

Sub PullQuestions()
'
' PullQuestions Macro
'
'
Dim curPar As Paragraph
' numLists = ActiveDocument.ListParagraphs.Count
' reprints each question on a new line at end of document'
For Each curPar In ActiveDocument.Paragraphs
If curPar.Selection.Style = "Question" Then
Selection.TypeText (curPar & vbCr)
End If
End Sub

1 Answer
1

I think you'll find the search function is probably more efficient for you. The following code will search the document and put the values into an array and then put them at the end of the document. It'll also set the paragraph style to reflect the original. Be aware you'll get a nasty output if you keep running it with the styles applied to the output at the end of the document.

I've commented it fairly well but let me know if it doesn't make sense.

Sub SearchStyles()
Dim iCount As Integer, iArrayCount As Integer, bFound As Boolean
'We'll store our result in an array so set this up (assume 50 entries)
ReDim sArray(1 To iArrayCount) As String
iArrayCount = 50
'State your Style type
sMyStyle = "Heading 1"
'Always start at the top of the document
Selection.HomeKey Unit:=wdStory
'Set your search parameters and look for the first instance
With Selection.Find
.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
.Style = sMyStyle
.Execute
End With
'If we find one then we can set off a loop to keep checking
'I always put a counter in to avoid endless loops for one reason or another
Do While Selection.Find.Found = True And iCount < 1000
iCount = iCount + 1
'If we have a result then add the text to the array
If Selection.Find.Found Then
bFound = True
'We do a check on the array and resize if necessary (more efficient than resizing every loop
If ii Mod iArrayCount = 0 Then ReDim Preserve sArray(1 To UBound(sArray) + iArrayCount)
sArray(iCount) = Selection.Text
'Reset the find parameters
Selection.Find.Execute
End If
Loop
'Finalise the array to the actual size
ReDim Preserve sArray(1 To iCount)
If bFound Then
'Output to the end of the document
ActiveDocument.Bookmarks("\EndOfDoc").Range.Select
Selection.TypeParagraph
For ii = LBound(sArray) To UBound(sArray)
Selection.Text = sArray(ii)
Selection.Range.Style = sMyStyle
Selection.MoveRight wdCharacter, 1
If ii < UBound(sArray) Then Selection.TypeParagraph
Next ii
End If
End Sub