I cannot test the following sample code in your environment, so I have made some assumptions:
1. I assume the code can run in the active document.
2. I assume you can create bookmarks in the active document with the following names:
"BkMk1" to span the 1st block of text that needs to be copied to the new document.
"BkMk2" to span the 2nd block of text that needs to be copied to the new document.
"BkMk3" to span the 3rd block of text that needs to be copied to the new document.
etc.
Select the relevant text then use Insert > Bookmark.
I hope the sample program will give you the basis for amending it to suit your environment.
Option Explicit
Public Sub FindCheckedBoxes()
' Declare object variables:
Dim objDOC1 As Word.Document
Dim objDOC2 As Word.Document
Dim objCCS As Word.ContentControls
Dim objCC As Word.ContentControl
Dim objRNG As Word.Range
Dim colBadBookmarks As Collection
' Declare other variables:
Dim lngAnswer As Long
Dim fOK As Boolean
Dim lngcI As Long
Dim lngcParaNo As Long
Dim strBookmarkName As String
Dim fBkMkExists As Boolean
Dim strText As String
' Call Message1() to ask user if OK to start:
lngAnswer = Message1()
If lngAnswer <> vbYes Then
GoTo Exit_FindCheckedBoxes
End If
' Instantiate document object for activedocument:
Set objDOC1 = ActiveDocument
' Quit if no bookmarks in ActiveDocument:
If objDOC1.Bookmarks.Count = 0 Then
Call Message2
GoTo Exit_FindCheckedBoxes
End If
' Point to content controls in the active document:
Set objCCS = objDOC1.ContentControls
' Quit if no content control is checked:
fOK = False
For lngcI = 1 To objCCS.Count
Set objCC = objCCS(lngcI)
If objCC.Checked Then
fOK = True
End If
Next
If Not fOK Then
Call Message3
GoTo Exit_FindCheckedBoxes
End If
' Quit if bookmarks don't exist for
' checked content controls:
Set colBadBookmarks = New Collection
For lngcI = 1 To objCCS.Count
Set objCC = objCCS(lngcI)
If objCC.Checked Then
strBookmarkName = "BkMk" & CStr(lngcI)
fBkMkExists = objDOC1.Bookmarks.Exists(strBookmarkName)
If Not fBkMkExists Then
colBadBookmarks.Add strBookmarkName
End If
End If
Next
If colBadBookmarks.Count > 0 Then
Call Message4(colBadBookmarks)
GoTo Exit_FindCheckedBoxes
End If
' Create a new document.
' If you want to use a special template when
' creating the new document, add template's name
' (in quotation marks as first parameter in
' brackets):
Set objDOC2 = Word.Application.Documents.Add()
' Point range object to insertion current point
' in new document:
Set objRNG = objDOC2.ActiveWindow.Selection.Range
' Loop through all (checked) content controls:
For lngcI = 1 To objCCS.Count
Set objCC = objCCS(lngcI)
If objCC.Checked Then
strBookmarkName = "BkMk" & CStr(lngcI)
GoSub ProcessOneContentControl
End If
Next
' Tell user we're finished:
Call Message5
Exit_FindCheckedBoxes:
' Destroy objects:
Set objRNG = Nothing
Set objDOC2 = Nothing
Set colBadBookmarks = Nothing
Set objCC = Nothing
Set objCCS = Nothing
Set objDOC1 = Nothing
Exit Sub
Error_FindCheckedBoxes:
MsgBox "Error No: " & Err.Number _
& vbNewLine & vbNewLine _
& "Error Description:" & vbNewLine _
& Err.Description, _
vbExclamation + vbOKOnly, _
"Error - Program Terminated"
GoTo Exit_FindCheckedBoxes
ProcessOneContentControl:
' Increment paragraph counter:
lngcParaNo = lngcParaNo + 1
' Use range object to insert text
' into new document:
With objRNG
' Insert new paragraph number and period:
.InsertAfter CStr(lngcParaNo) & "."
' Insert a tab stop:
.InsertAfter vbTab
' Get text from ActiveDocument:
strText = objDOC1.Bookmarks(strBookmarkName).Range.Text
' Copy text to new document:
.InsertAfter strText
' Insert a line space:
.InsertAfter vbNewLine
' For good measure, nove range object
' to beginning of next paragraph:
.Collapse wdCollapseEnd
End With
Return
End Sub
Private Function Message1() As VbMsgBoxResult
Dim strMessage As String
Dim lngOptions As VbMsgBoxStyle
Dim strHeading As String
' Prepare question:
strMessage = "OK to copy checked text to new document?"
lngOptions = vbQuestion + vbYesNo + vbDefaultButton2
strHeading = "Program Starting"
' Ask question and return answer to calling routine:
Message1 = MsgBox(strMessage, lngOptions, strHeading)
End Function
Private Sub Message2()
Dim strMessage As String
Dim lngOptions As VbMsgBoxStyle
Dim strHeading As String
strMessage = "No bookmarks found in Active " _
& "Document." & vbNewLine _
& "Bookmarks must be defined " _
& "for each block of text that needs to " _
& "be copied to the new document." & vbNewLine _
& "Bookmark names must be in the form BkMk1, " _
& "BkMk2, BkMk3, etc."
lngOptions = vbExclamation + vbOKOnly
strHeading = "Program Finished"
MsgBox strMessage, lngOptions, strHeading
End Sub
Private Sub Message3()
Dim strMessage As String
Dim lngOptions As VbMsgBoxStyle
Dim strHeading As String
strMessage = "No content control was checked." _
& vbNewLine _
& "The program has been terminated."
lngOptions = vbExclamation + vbOKOnly
strHeading = "Program Terminated" & Space(35)
MsgBox strMessage, lngOptions, strHeading
End Sub
Private Sub TestMsg4()
Dim colC As Collection
Set colC = New Collection
colC.Add "BkMk1"
colC.Add "BkMk2"
colC.Add "BkMk3"
Call Message4(colC)
Set colC = Nothing
End Sub
Private Sub Message4(objCOL As Collection)
Dim strMessage As String
Dim lngOptions As VbMsgBoxStyle
Dim strHeading As String
Dim varBkMk As Variant
strMessage = "The following bookmarks are missing:" _
& vbNewLine & vbNewLine
For Each varBkMk In objCOL
strMessage = strMessage & varBkMk & ", "
Next
strMessage = Left(strMessage, Len(strMessage) - 2)
lngOptions = vbExclamation + vbOKOnly
strHeading = "Program Terminated"
MsgBox strMessage, lngOptions, strHeading
End Sub
Private Sub Message5()
Dim strMessage As String
Dim lngOptions As VbMsgBoxStyle
Dim strHeading As String
strMessage = "New document has been created " _
& "and checked paragraphs copied."
lngOptions = vbOKOnly + vbInformation
strHeading = "Program Finished Normally"
MsgBox strMessage, lngOptions, strHeading
End Sub
