Вставить текст из Excel под различными заголовками

Question

В документ Word я вставляю разные тексты из документа Excel в зависимости от заголовка с написанным мной кодом.

Проблема в том, что текст адаптирует стиль заголовков. Я хочу, чтобы текст был «стандартным», а не заголовком.

Как изменить стиль текста?

Sub Dokumentenbefuellung() 
    Application.ScreenUpdating = False
    Const wdReplaceAll = 2
    Const wdNoProtection = -1
    Dim oAppWD As Object, oDoc As Object
    Dim x, i, a, b, y  As Variant
    Dim Dokumente, Ueberschrift, strString, Oberordner, Name As String
    Dim rngCell As Range
     
    Dokumente = "Source"
    Oberordner = ActiveWorkbook.Sheets("Eingabefenster").Range("B6").Value
    Name= ActiveWorkbook.Sheets("Eingabefenster").Range("B18").Value
    If Dir(Dokumente) <> "" Then ' Falls ein Dokument existiert, soll die Word Applikation gestartet werden
        Set oAppWD = CreateObject("Word.Application") 'Word als Object starten
    Else
        MsgBox "Die zu öffnende Dokumentdatei wurde nicht gefunden!", vbCritical, "Word-Datei öffnen"
        End
    End If
        
    If Not oAppWD Is Nothing Then
        oAppWD.Visible = True
        If oAppWD.Options.AllowReadingMode = True Then 'Word nicht im Lesemodus starten bei Schreibgeschützten Dokumenten
            oAppWD.Options.AllowReadingMode = False
        End If
    End If
        
    b = ActiveWorkbook.Sheets("Inhalteeinfuegen").Cells(Rows.Count, 1).End(xlUp).Row
     
    For a = 2 To b
           
        Set oDoc = oAppWD.Documents.Open(Dokumente)
        Application.DisplayAlerts = False
        If Not oDoc Is Nothing Then
            If oDoc.ProtectionType <> wdNoProtection Then
                oDoc.Unprotect
            End If
        End If
           
        ThisWorkbook.Activate
        Sheets("Inhalteeinfuegen").Activate
    
        Ueberschrift = "Überschrift" & " " & ActiveWorkbook.Sheets("Inhalteeinfuegen").Cells(a, 2).Value
        ThisWorkbook.Activate
        With oAppWD.Selection.Find      
            .Forward = True
            .ClearFormatting
            .Style = Ueberschrift
            .MatchWholeWord = True
            .MatchCase = False
            .Wrap = wdfindContinue
            .Execute FindText:=ActiveWorkbook.Sheets("Inhalteeinfuegen").Cells(a, 3).Value
        End With

        oAppWD.Selection.InsertParagraphAfter
        oAppWD.Selection.InsertParagraphAfter
        oAppWD.Selection.InsertAfter Text:=ActiveWorkbook.Sheets("Inhalteeinfuegen").Cells(a, 4).Value
               
    Next a
            
    oDoc.Save         'Dokument speichern
    oDoc.Close        'Dokument schließen
    oAppWD.Quit       'Word schließen
    Set oAppWD = Nothing
    Set oDoc = Nothing
End Sub

Answer 1

В вашем коде есть несколько проблем, включая:

• несколько неиспользуемых переменных;
• переменные объявлены неправильно (например, в 'Dim Dokumente, Ueberschrift, strString, Oberordner, Name As String », все варианты, кроме« Name »); и
• оставляя все, кроме последнего открытого документа, открытым и несохраненным при выходе из Word.

Что касается проблемы с форматированием, это связано с тем, что новое содержимое вставляется в Try:

Sub Dokumentenbefuellung()
Application.ScreenUpdating = False
Dim oWdApp As Object, oWdDoc As Object, oWdRng As Object
Dim Dokumente As String, Ueberschrift As String, Oberordner As String, Name As String
Dim xlWkSht1 As Worksheet, xlWkSht2 As Worksheet, a As Long
Const wdReplaceAll = 2: Const wdNoProtection = -1: Const wdStyleNormal = -1
Dokumente = "Source"
If Dir(Dokumente) <> "" Then ' Falls ein Dokument existiert, soll die Word Applikation gestartet werden
  Set oWdApp = CreateObject("Word.Application") 'Word als Object starten
Else
  MsgBox "Die zu öffnende Dokumentdatei wurde nicht gefunden!", vbCritical, "Word-Datei ?ffnen"
  End
End If

With ActiveWorkbook
  Set xlWkSht1 = .Sheets("Eingabefenster"): Set xlWkSht2 = .Sheets("Inhalteeinfuegen")
End With
Oberordner = xlWkSht1.Range("B6").Text: Name = xlWkSht1.Range("B18").Text

If Not oWdApp Is Nothing Then
  With oWdApp
    .Visible = True
    .Options.AllowReadingMode = False

    For a = 2 To xlWkSht2.Cells(Rows.Count, 1).End(xlUp).Row
      Set oWdDoc = .Documents.Open(Dokumente)
      With oWdDoc
        If .ProtectionType <> wdNoProtection Then .Unprotect
        Ueberschrift = "Überschrift" & " " & xlWkSht2.Cells(a, 2).Text
        With .Range
          With .Find
            .Forward = True
            .ClearFormatting
            .Style = Ueberschrift
            .Text = xlWkSht2.Cells(a, 3).Text
            .MatchWholeWord = True
            .MatchCase = False
            .Wrap = wdFindContinue
            .Execute
          End With
          If .Find.Found = True Then
            Set oWdRng = .Duplicate.Characters.Last
            With oWdRng

              .InsertAfter vbCr
              .Collapse 0 'wdCollapseEnd
              .Text = vbCr & xlWkSht2.Cells(a, 4).Text
              .Paragraphs.Style = oWdDoc.Styles(wdStyleNormal).NameLocal
            End With
        End With
        .Close True 'Dokument speichern & schließen
      End With
    Next a
    .Quit       'Word schließen
  End With
End If

Set oWdDoc = Nothing: Set oWdApp = Nothing
Set xlWkSht1 = Nothing: Set xlWkSht2 = Nothing
End Sub