VBA Selection.PasteAndFormat einen Zeilenumbruch hinzufügen

Question

Ich habe ein VBA-Skript, das eine benannte Zelle in Excel findet und in Word basierend auf einem Bezeichner, den ich in Word habe, einfügt. Ich verwende RegEx, um den Bezeichner zu finden.

Das Problem, das ich erfahre, ist, wann immer es den Wert (richtig) es "drückt Enter", so dass es in die nächste Zeile geht. Es sollte nicht.

Hier ist das Skript:

Dim objWord, objWordDoc, RegEx, objExcel, objWorkbook, content, texts, text, Text_Name 

Set RegEx = CreateObject("VBScript.RegExp") 

Set objWord = CreateObject("Word.Application") 
Set objExcel = CreateObject("Excel.Application") 

Set objWordDoc = objWord.Documents.Open("D:\Performance Review Template Rev1.docx", False, True) 
Set objWorkbook = objExcel.Workbooks.Open("D:\Template Rev1.xlsm", False, True) 

'The entire content of the Word Document 
Set content = objWord.ActiveDocument.Content 

'The Regular Expression in terms of finding the short code within the document 
'Explanation 
'----------- 
'\[# == Escaped [# characters to indicate that the start of the search needs to be an [# 
'(.*?) == The forward seach in a non greedy way that is also the return group 
'\] == Escaped ] character that signals the end of the search term 
RegEx.Pattern = "\[#(.*?)\]" 
RegEx.Global = True 

Set texts = RegEx.Execute(content) 
Dim Found 

For Each text In texts 
    Set content = objWord.ActiveDocument.Content 
    'Find the TextName that is in the short code. The Submatches property returns 
    'the value of the inner return group, whereas the .Value property only returns 
    'the value of the short code with the [!xxx] added 
    Text_Name = text.submatches(0) 
    Dim xName, xText 
    Found = False 
    'Search for the text through all the Named Cells in the Excel file 

    objExcel.Range(Text_Name).Copy 

    With content.Find 
     .MatchWholeWord = True 
     .Text = text.Value 
     .Execute 
     If .Found = True Then 
      Found = True 
      content.PasteAndFormat 20 
     End If 
    End With 

    If Found = False Then 
     MsgBox "Did not find Named Cell!" 
    End If 

    With content.Find 
     .Text = text.Value 
     .Execute 
     If .Found = True Then 
      objWord.Selection.Range.Delete 
     End If 
    End With  
Next 

MsgBox "Completed named cells" 

objWord.ActiveDocument.Close 
objWord.Application.Quit 

objExcel.ActiveWorkbook.Close 
objExcel.Application.Quit 

Wie immer ist jede Hilfe immer willkommen.

Answer 1

Dies scheint das Standardverhalten der Kopierfunktionalität zu sein (manuell wird dasselbe Ergebnis erzielt). Vorgeschlagene Lösung könnte sein, direktes Kopieren des Inhalts anstelle der Verwendung der Kopie & Paste zu verwenden.

Die Formatierung wird auch vom Zieldokument beibehalten. Hier wird getestet Code (Änderungen mit %%%% markiert):

Dim objWord, objWordDoc, RegEx, objExcel, objWorkbook, content, texts, text, Text_Name, copiedText ' %%%% Added variable 

Set RegEx = CreateObject("VBScript.RegExp") 

Set objWord = CreateObject("Word.Application") 
Set objExcel = CreateObject("Excel.Application") 

Set objWordDoc = objWord.Documents.Open("D:\Performance Review Template Rev1.docx", False, True) 
Set objWorkbook = objExcel.Workbooks.Open("D:\Template Rev1.xlsm", False, True) 

'The entire content of the Word Document 
Set content = objWord.ActiveDocument.content 

'The Regular Expression in terms of finding the short code within the document 
'Explanation 
'----------- 
'\[# == Escaped [# characters to indicate that the start of the search needs to be an [# 
'(.*?) == The forward seach in a non greedy way that is also the return group 
'\] == Escaped ] character that signals the end of the search term 
RegEx.Pattern = "\[#(.*?)\]" 
RegEx.Global = True 

Set texts = RegEx.Execute(content) 
Dim Found 

For Each text In texts 
    Set content = objWord.ActiveDocument.content 
    'Find the TextName that is in the short code. The Submatches property returns 
    'the value of the inner return group, whereas the .Value property only returns 
    'the value of the short code with the [!xxx] added 
    Text_Name = text.submatches(0) 
    Dim xName, xText 
    Found = False 
    'Search for the text through all the Named Cells in the Excel file 

    copiedText = objExcel.Range(Text_Name).text ' %%%% 
    ' %%%% Instead of objExcel.Range(Text_Name).Copy 

    With content.Find 
     .MatchWholeWord = True 
     .text = text.Value 
     .Execute 
     If .Found = True Then 
      Found = True 
      .Parent.text = copiedText ' %%%% 
      ' %%%% Instead of content.PasteAndFormat 20 
     End If 
    End With 

    If Found = False Then 
     MsgBox "Did not find Named Cell!" 
    End If 

    With content.Find 
     .text = text.Value 
     .Execute 
     If .Found = True Then 
      objWord.Selection.Range.Delete 
     End If 
    End With 
Next 

MsgBox "Completed named cells" 

objWord.ActiveDocument.Close 
objWord.Application.Quit 

objExcel.ActiveWorkbook.Close 
objExcel.Application.Quit