求助：用VBA宏按问卷逻辑生成各国专属问卷（空文档问题）

问题根源 #

1. 颜色匹配失效：若主文档中的橙色是通过Word主题色设置，而非直接指定RGB值，原代码的para.Range.Font.Color无法匹配预设RGB，导致所有「ASK」行都未被识别
2. 段落文本干扰：原代码未排除段落标记（Chr(13)），可能导致「ASK」前缀判断失败
3. 粘贴逻辑缺陷：直接使用countryDoc.Content.Paste可能出现内容覆盖或追加位置错误

修正后的VBA代码 #

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 orangeRGB As Long
    Const savePath As String = "PATH" ' 替换为实际保存路径

    ' 目标橙色RGB值
    orangeRGB = RGB(237, 125, 49)
    
    Set sourceDoc = ActiveDocument
    Set countryList = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False

    ' 第一遍：提取所有涉及的国家
    For Each para In sourceDoc.Paragraphs
        ' 兼容直接RGB和主题色转换后的颜色匹配
        If para.Range.Font.Color = orangeRGB Or _
           RGB(para.Range.Font.Color.RGB) = orangeRGB Then
            ' 移除段落标记后处理文本
            currentLine = Trim(Replace(para.Range.Text, Chr(13), ""))
            If UCase(Left(currentLine, 4)) = "ASK " Then
                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
                    End If
                Next i
            End If
        End If
    Next para

    ' 第二遍：为每个国家生成专属问卷
    For Each country In countryList.Keys()
        Set countryDoc = Documents.Add
        Dim targetRange As Range
        Set targetRange = countryDoc.Content
        
        For Each para In sourceDoc.Paragraphs
            If para.Range.Font.Color = orangeRGB Or _
               RGB(para.Range.Font.Color.RGB) = orangeRGB Then
                currentLine = Trim(Replace(para.Range.Text, Chr(13), ""))
                If UCase(Left(currentLine, 4)) = "ASK " Then
                    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
                        ' 将ASK行追加到目标文档末尾
                        para.Range.Copy
                        targetRange.Collapse Direction:=wdCollapseEnd
                        targetRange.Paste
                        
                        ' 复制后续的问题段落（排除ASK行）
                        Dim nextPara As Paragraph
                        Set nextPara = para.Next
                        If Not nextPara Is Nothing Then
                            If Not (nextPara.Range.Font.Color = orangeRGB Or _
                                    RGB(nextPara.Range.Font.Color.RGB) = orangeRGB) Then
                                targetRange.Collapse Direction:=wdCollapseEnd
                                targetRange.InsertParagraphAfter
                                nextPara.Range.Copy
                                targetRange.Collapse Direction:=wdCollapseEnd
                                targetRange.Paste
                                targetRange.Collapse Direction:=wdCollapseEnd
                                targetRange.InsertParagraphAfter
                                targetRange.InsertParagraphAfter
                            End If
                        End If
                    End If
                End If
            End If
        Next para

        ' 删除文档末尾的空段落
        Do While countryDoc.Paragraphs.Count > 0 And _
               Len(Trim(Replace(countryDoc.Paragraphs.Last.Range.Text, Chr(13), ""))) = 0
            countryDoc.Paragraphs.Last.Range.Delete
        Loop

        ' 处理文件名非法字符
        Dim safeCountry As String
        safeCountry = Replace(Replace(Replace(Replace(country, "\\", ""), "/", ""), ":", ""), "*", "")
        safeCountry = Replace(Replace(safeCountry, "?", ""), """", "")
        
        countryDoc.SaveAs2 FileName:=savePath & "questionnaire_" & safeCountry & ".docx", _
                         FileFormat:=wdFormatXMLDocument
        countryDoc.Close
    Next country

    Application.ScreenUpdating = True
    MsgBox "已成功生成 " & countryList.Count & " 个国家的问卷文档。", vbInformation
End Sub

关键修改说明 #

• 优化颜色判断逻辑，兼容直接RGB和Word主题色两种设置方式
• 移除段落标记后再做文本判断，避免标记干扰「ASK」前缀匹配
• 使用Collapse(wdCollapseEnd)控制粘贴位置，确保内容追加到文档末尾
• 增加对更多文件名非法字符的处理，避免保存失败
• 将原Do循环改为For Each循环，遍历段落更稳定可靠

内容的提问来源于stack exchange，提问作者maplesyrup123