从 Excel 填充 Word 中的文本框

Question

我在一个word文档中有24个文本框如下图所示：

我正在尝试使用工作表中以下范围内每个单元格的内容进行填充，如下所示：

一次三行：因为有 24 个文本框，所以 3 行 8 列每次将有 24 个单元格：

然后我会用一个唯一的名称保存它并从接下来的 3 行中新建：

代码：

Option Explicit
Sub TransferData()

Dim FRow As Long, i As Long, j As Long
Dim wk As Worksheet, wt As Worksheet
Dim Path As String, Folder As String, File As String, CandName As String

    Set wt = Sheet2 'Temp
    Set wk = Sheet1 'Main
    FRow = wk.Range("D" & Rows.Count).End(xlUp).Row

    wt.Cells.Clear
    wk.Range("D6:K" & FRow).Copy
    wt.Activate
    wt.Range("A1").Select
    wt.Paste
    Application.CutCopyMode = False
    wt.Columns.AutoFit

    FRow = wt.Range("A" & Rows.Count).End(xlUp).Row
    wt.Range("$A$1:$H$" & FRow).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8), Header:=xlYes


'----------Deduping is Done Now Transferring Data from eXcel to Word---------------
    Path = Trim(wk.Range("A6").Text)
    Folder = Trim(wk.Range("A10").Text)
    File = Trim(wk.Range("A14").Text)

    Dim Rng As Range
    Dim r As Long, ct As Long, col As Long

    Dim wdApp As Word.Application, wdDoc As Word.Document
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
        If Err.Number <> 0 Then 'Word isn't already running
        Set wdApp = CreateObject("Word.Application")
        End If
    On Error GoTo 0
    Set wdDoc = wdApp.Documents.Open(Path & "\" & Folder & "\" & File)


    With wt
        FRow = .Range("A" & Rows.Count).End(xlUp).Row
        Set Rng = .Range("A2:G" & FRow)
    End With

    With Rng
    r = 2
       Do

         Set wdDoc = wdApp.Documents.Open(Path & "\" & Folder & "\" & File)
         CandName = Trim(.Range("A" & r).Text)
         col = 0
                For i = 1 To 24

                     If i Mod 9 = 0 Then
                        r = r + 1
                        col = 1
                      Else
                        col = col + 1
                      End If

                 wdDoc.Shapes("Text Box " & i).TextFrame.TextRange.Text = .Cells(r, col).Value
                Next i
         ActiveDocument.SaveAs Filename:=Path & "\" & Folder & "\" & "New Files\" & "_" & CandName & r
        Loop Until .Range("A" & r).Text <> ""
    End With

End Sub

我不知道的：

1. 如何重命名word文档中的文本框（手动或代码），以便在宏中使用。

2. 保存 word 文档并使用 24 个文本框创建新的 Word 文档，以便再次填充它们。

Answer 1

根据您的要求，我修改了您的代码。 我无法自己测试它，因为有些变量我无法访问（路径、文件夹），所以如果无法编译和工作，请查看我在接近尾声时所做的事情并尝试修改自己。

基本上，在 3 行之后，我指示将当前文件另存为新文件，然后再次打开 24-blank-textboxes 文件，该文件将在 3 行等后再次保存......

顺便说一句，您提到您想更改文本框的名称，但您的代码中没有任何内容。如果你想这样做，你需要给我们写更多关于它的代码。

Option Explicit
Sub TransferData()

Dim FRow As Long, i As Long, j As Long     
Dim wk As Worksheet, wt As Worksheet
Dim Path As String, Folder As String, File As String, CandName As String

Set wt = Sheet2 'Temp
Set wk = Sheet1 'Main
FRow = wk.Range("D" & Rows.Count).End(xlUp).Row

wt.Cells.Clear
wk.Range("D6:K" & FRow).Copy
wt.Activate
wt.Range("A1").Select
wt.Paste
Application.CutCopyMode = False
wt.Columns.AutoFit

FRow = wt.Range("A" & Rows.Count).End(xlUp).Row
wt.Range("$A$1:$H$" & FRow).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5,
6, 7, 8), Header:=xlYes


'----------Deduping is Done Now Transferring Data from eXcel to Word-------     
Path = Trim(wk.Range("A6").Text)
Folder = Trim(wk.Range("A10").Text)
File = Trim(wk.Range("A14").Text)

Dim Rng As Range
Dim r As Long, ct As Long, col As Long

Dim wdApp As Word.Application, wdDoc As Word.Document
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then 'Word isn't already running
    Set wdApp = CreateObject("Word.Application")
    End If
On Error GoTo 0
Set wdDoc = wdApp.Documents.Open(Path & "\" & Folder & "\" & File)


With wt
    FRow = .Range("A" & Rows.Count).End(xlUp).Row
    Set Rng = .Range("A2:G" & FRow)
End With

With Rng
r = 2

   Do


     CandName = Trim(.Range("A" & r).Text)
     col = 0
            For i = 1 To 24

                 If i Mod 9 = 0 Then
                    r = r + 1
                    col = 1
                  Else
                    col = col + 1
                  End If

             wdDoc.Shapes("Text Box " & i).TextFrame.TextRange.Text =_             
             .Cells(r, col).Value          
            Next i

            if (r-2) mod 3 = 0 then
            ActiveDocument.SaveAs Filename:=Path & "\" & Folder & "\" &_ 
            "New Files\" & "_" & CandName & r
            Set wdApp = Nothing 
            Set wdApp = GetObject(, "Word.Application")
             If Err.Number <> 0 Then 'Word isn't already running
             Set wdApp = CreateObject("Word.Application")
             End If
            Set wdDoc = wdApp.Documents.Open(Path & "\" & Folder & "\" &_
            File)                
            end if 

    Loop Until .Range("A" & r).Text <> ""
End With
End Sub

Answer 2

1. 将 textBox1 重命名为 textBox2 的代码：

   ActiveDocument.Shapes("Text Box 1").Select
   ActiveDocument.Shapes("Text Box 1").Name = "Text Box 2"
   

如果不首先选择文本框（或任何其他形状），则无法修改其名称。

1. 您已经在代码中完成了该操作，只需重新使用该行：

   Set wdDoc = wdApp.Documents.Open(Path & "\" & Folder & "\" & File)
   

..打开一个新文件并重新开始。确保关闭不再需要的文档，否则您最终会得到 24 个打开的文档。我认为你不需要那个。