Заполните документ Word большим текстом

Question

Я пытаюсь заполнить документ Word текстом замены, который слишком велик для вставки. Может ли кто-нибудь мне помочь? Я пытаюсь часами и не могу найти рабочий метод.

Мой код:

Dim lastRow As Integer
Dim lastCol As Integer

lastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
lastCol = ActiveSheet.Cells(2, Columns.Count).End(xlToLeft).Column

Dim wApp As Object
Dim wDoc As Word.Document

Set wApp = CreateObject("Word.Application")

wApp.Visible = True

For srow = 2 To lastRow
    Set wDoc = wApp.Documents.Open("C:\Temp\Template.docx")
    For scol = 1 To lastCol
        With wDoc.Content.Find
            .Text = "$" & ActiveSheet.Cells(1, scol) & "$"
            ***.Replacement.Text = ActiveSheet.Cells(srow, scol)*** 'This is where the code stops. Thats too big.
            .Execute Replace:=wdReplaceAll
        End With
    Next
    wApp.ActiveDocument.SaveAs "C:\Temp\1.class\" & ActiveSheet.Cells(srow, 1) & ".docx"
Next

Answer 1

Выражения поиска и замены слов не могут быть длиннее 255 символов. Попробуйте что-то вроде:

Sub Demo()
Dim lastRow As Long, lastCol As Long, sRow As Long, sCol As Long
Dim xlSht As Worksheet, wdApp As Object, wdDoc As Object
Dim StrFnd As String, StrRep As String

lastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
lastCol = ActiveSheet.Cells(2, Columns.Count).End(xlToLeft).Column
Set xlSht = ActiveSheet
Set wdApp = CreateObject("Word.Application")

With wdApp
  .Visible = True
  Set wdDoc = .Documents.Open("C:\Temp\Template.docx", , False, False, , , , , , , , False)
  With wdDoc
    For sRow = 2 To lastRow
      For sCol = 1 To lastCol
        StrFnd = "$" & xlSht.Cells(1, sCol).Text & "$"
        StrRep = xlSht.Cells(sRow, sCol).Text
        If Len(StrRep) < 256 Then
          .Range.Find.Execute StrFnd, StrRep, , , , , , 1, , , 2
        Else
          With .Range
            With .Find
              .Text = StrFnd
              .Replacement.Text = StrRep
              .Wrap = 0
              .Execute
            End With
            Do While .Find.Found = True
              .Text = StrFnd
              .Collapse 0
              .Find.Execute
            Loop
          End With
        End If
      Next
      .SaveAs "C:\Temp\1.class\" & ActiveSheet.Cells(sRow, 1).Text & ".docx"
    Next
  End With
  .Quit
End With
Set wdDoc = Nothing: Set wdApp = Nothing: Set xlSht = Nothing
End Sub