Create new documents based on questionnaire logic

Question

I am trying to create separate documents for each country I will send a questionnaire to, and I am struggling. Basically, I have a master document with this questionnaire:

ASK CANADA, GERMANY, ITALY

How old are you?

ASK CANADA

Canada

ASK GERMANY

Germany

ASK ITALY

Italy

Only difference is that instead of bold I am using orange (RGB: 237, 125, 49) for the logic of the questionnaire.

What I would like to obtain is a document named "questionnaire_CANADA" containing the following, with no format changes (i.e., keeping the orange, all caps etc.):

ASK CANADA, GERMANY, ITALY

How old are you?

ASK CANADA

Canada

Same for the other countries (there are more than these 3 in the original questionnaire).

Is something like this even possible with a macro? Below my (sloppy) attempt - with this I only get the three documents correctly named but empty.

Sub CreateCountryQuestionnaires()
    Dim sourceDoc As Document
    Dim countryDoc As Document
    Dim para As Paragraph
    Dim countryList As Object
    Dim country As Variant
    Dim currentLine As String
    Dim i As Integer
    Dim orangeColor As Long
    Const savePath As String = "PATH"
    
    ' Set the orange color (RGB: 237, 125, 49)
    orangeColor = RGB(237, 125, 49)
    
    ' Initialize
    Set sourceDoc = ActiveDocument
    Set countryList = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    
    ' First pass: Find all countries
    For Each para In sourceDoc.Paragraphs
        If para.Range.Font.Color = orangeColor Then
            currentLine = Trim(para.Range.Text)
            If UCase(Left(currentLine, 4)) = "ASK " Then
                ' Extract countries from the ASK line
                Dim countries() As String
                countries = Split(Mid(currentLine, 5), ",")
                
                For i = 0 To UBound(countries)
                    Dim trimmedCountry As String
                    trimmedCountry = Trim(countries(i))
                    If Len(trimmedCountry) > 0 Then
                        countryList(trimmedCountry) = 1 ' Track country
                    End If
                Next i
            End If
        End If
    Next para
    
    ' Second pass: Create documents for each country
    For Each country In countryList.Keys()
        ' Create new document
        Set countryDoc = Documents.Add
        
        ' Process paragraphs in order
        Set para = sourceDoc.Paragraphs.First
        Do While Not para Is Nothing
            If para.Range.Font.Color = orangeColor Then
                currentLine = Trim(para.Range.Text)
                If UCase(Left(currentLine, 4)) = "ASK " Then
                    ' Check if this ASK line includes our country
                    Dim askCountries() As String
                    askCountries = Split(Mid(currentLine, 5), ",")
                    Dim includeThis As Boolean
                    includeThis = False
                    
                    For i = 0 To UBound(askCountries)
                        If Trim(askCountries(i)) = country Then
                            includeThis = True
                            Exit For
                        End If
                    Next i
                    
                    If includeThis Then
                        ' Copy ASK line with formatting
                        para.Range.Copy
                        countryDoc.Content.Paste
                        
                        ' Copy the next paragraph if it's a question
                        Dim nextPara As Paragraph
                        Set nextPara = para.Next
                        
                        If Not nextPara Is Nothing Then
                            If nextPara.Range.Font.Color <> orangeColor Then
                                countryDoc.Content.InsertAfter vbCrLf
                                nextPara.Range.Copy
                                countryDoc.Content.Paste
                                countryDoc.Content.InsertAfter vbCrLf & vbCrLf
                            End If
                        End If
                    End If
                End If
            End If
            Set para = para.Next
        Loop
        
        ' Remove empty paragraphs at end
        Do While countryDoc.Paragraphs.Count > 0 And _
               Len(Trim(countryDoc.Paragraphs.Last.Range.Text)) = 0
            countryDoc.Paragraphs.Last.Range.Delete
        Loop
        
        ' Save the document
        Dim safeCountry As String
        safeCountry = Replace(Replace(Replace(country, "\", ""), "/", ""), ":", "")
        
        countryDoc.SaveAs2 FileName:=savePath & "questionnaire_" & safeCountry & ".docx", _
                         FileFormat:=wdFormatXMLDocument
        countryDoc.Close
    Next country
    
    Application.ScreenUpdating = True
    
    MsgBox "Successfully created questionnaires for " & countryList.Count & " countries.", vbInformation
End Sub

Thanks in advance for any help!

This would be a simple undertaking for a document using Heading Styles for the headings related to each country, in which case, you could simply use a macro-driven Find/Replace to delete all heading ranges not associated with a particular country. — macropod
– macropod, Commented Jul 22 at 6:18
The only issue is that I cannot really change the questionnaire or use heading styles... I have this version and I am trying to automate the creation of separate questionnaire by using the logic above each question. — maplesyrup123
– maplesyrup123, Commented Jul 22 at 10:16
Nothing in what you've posted so far suggests any valid reason for not using a Heading Style. All you'd need to do is format one with your desired orange color and replace the existing orange text with the Heading Style. Simple as. You could then use the approach outlined in my previous comment. — macropod
– macropod, Commented Jul 22 at 10:29

Ike · Accepted Answer · 2025-07-22 12:08:56Z

I am assuming that the VBA code runs in the source file. If not you have to adjust the first part of createDocs

Furthermore I am assuming that you know the list of countries.


Sub createDocs()

Dim docSource As Word.Document : Set docSource = ThisDocument

Dim arrCountries(2) As String
arrCountries(0) = "CANADA"
arrCountries(1) = "GERMANY"
arrCountries(2) = "ITALY"

Dim i As Long
Dim docTarget As Word.Document

For i = 0 To UBound(arrCountries)
    Set docTarget = getCopy(docSource, arrCountries(i))
    keepCountryContent docTarget, arrCountries(i)
    docTarget.Close True
Next

End Sub


Private Sub keepCountryContent(doc As Document, country As String)

Dim p As Paragraph, i As Long
For i = doc.Paragraphs.Count To 1 Step -1   'from end to beginning of document
    Set p = doc.Paragraphs(i)
    If isParaHeader(p) Then
        If isParaCountry(p, country) = False Then
            removeParaSection p
        End If
    End If
Next

End Sub

   
Private Function isParaHeader(p As Paragraph) As Boolean
    isParaHeader = p.Range.Font.Bold = True '--> adjust this to your condition
End Function

Private Function isParaCountry(p As Paragraph, country As String) As Boolean
    isParaCountry = InStr(p.Range.Text, country) > 0
End Function


Private Sub removeParaSection(p As Paragraph)

    Dim pX As Paragraph, rgToDelete As Word.Range
    
    Set rgToDelete = p.Range: Set pX = p
    Do
        If pX.Range.End = p.Parent.Paragraphs.Last.Range.End Then
            Exit Do
        End If
        
        Set pX = pX.Next
        If isParaHeader(pX) = False Then
            rgToDelete.End = pX.Range.End
        Else
            Exit Do
        End If
    Loop
    
    rgToDelete.Delete
End Sub


Private Function getCopy(docSource As Word.Document, country As String) As Word.Document
    
    'If docSource <> ThisDocument you could use FileCopy instead
    
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject

    Dim docTargetFullname As String, docTarget As Word.Document
    docTargetFullname = docSource.Path & "\questionnaire_" & country & ".doc"
    
    fso.CopyFile docSource.FullName, docTargetFullname & "m"
    Set docTarget = Application.Documents.Open(docTargetFullname & "m")
    
    docTarget.SaveAs2 docTargetFullname & "x", WdSaveFormat.wdFormatXMLDocument
    
    Kill docTargetFullname & "m"
    
    Set getCopy = docTarget
    
End Function

maplesyrup123 · Accepted Answer · 2025-07-23 08:30:59Z

After much tinkering, I managed to get what I wanted with this:

Sub CreateCountryQuestionnaires()
    Dim countries As Variant
    countries = Array("CANADA", "GERMANY", "ITALY")
    
    Dim doc As Document, newDoc As Document
    Set doc = ActiveDocument
    
    Dim para As Paragraph
    Dim originalPara As Paragraph
    Dim i As Long, j As Long, country As Variant
    Dim inBlock As Boolean, includeBlock As Boolean
    Dim currentBlockStart As Long
    Dim logicText As String
    Dim savePath As String
    savePath = "C:\Users\piera\Desktop\"
    
    Dim orangeColor As Long
    orangeColor = RGB(237, 125, 49)
    
    For Each country In countries
        Set newDoc = Documents.Add
        inBlock = False
        includeBlock = False
        i = 1
        
        Do While i <= doc.Paragraphs.Count
            logicText = Trim(doc.Paragraphs(i).Range.Text)
            
            ' Start of a new logic block
            If UCase(Left(logicText, 3)) = "ASK" Then
                ' If we were in a relevant block, copy its content
                If inBlock And includeBlock Then
                    For j = currentBlockStart To i - 1
                        Set originalPara = doc.Paragraphs(j)
                        
                        With newDoc.Range
                            .Collapse Direction:=wdCollapseEnd
                            .FormattedText = originalPara.Range.FormattedText
                        End With
                        
                        ' If logic line, recolor only that paragraph
                        If UCase(Left(Trim(originalPara.Range.Text), 3)) = "ASK" Then
                            newDoc.Paragraphs.Last.Range.Font.Color = orangeColor
                        End If
                    Next j
                End If
                
                ' Start new block
                inBlock = True
                currentBlockStart = i
                includeBlock = (InStr(logicText, "ALL") > 0 Or InStr(logicText, country) > 0)
            End If
            
            i = i + 1
        Loop
        
        ' Handle final block at end of document
        If inBlock And includeBlock Then
            For j = currentBlockStart To doc.Paragraphs.Count
                Set originalPara = doc.Paragraphs(j)
                
                With newDoc.Range
                    .Collapse Direction:=wdCollapseEnd
                    .FormattedText = originalPara.Range.FormattedText
                End With
                
                If UCase(Left(Trim(originalPara.Range.Text), 3)) = "ASK" Then
                    newDoc.Paragraphs.Last.Range.Font.Color = orangeColor
                End If
            Next j
        End If
        
        newDoc.SaveAs2 FileName:=savePath & "questionnaire_" & country & ".docx", FileFormat:=wdFormatXMLDocument
        newDoc.Close
    Next country
    
    MsgBox "Questionnaires created!"
End Sub

Collectives™ on Stack Overflow

Create new documents based on questionnaire logic

2 Answers 2

Comments

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Related