Vba 从Excel填充Word中的文本框

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

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

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

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

代码：

我不知道的是：

如何手动或通过word文档中的代码重命名文本框，以便在宏中使用

保存word文档并创建包含24个文本框的新word文档，以便再次填充

将textBox1重命名为textBox2的代码：

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

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

您已经在代码中这样做了，只需重复使用以下行：

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

..打开新文件并重新开始。确保关闭不再需要的文档，否则最终会有24个打开的文档。我想你不需要这个

将textBox1重命名为textBox2的代码：

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

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

您已经在代码中这样做了，只需重复使用以下行：

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

---

..打开新文件并重新开始。确保关闭不再需要的文档，否则最终会有24个打开的文档。我想你不需要它。

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

基本上，在3行之后，我已经指示将当前文件保存为新文件，并再次打开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


     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

---

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

基本上，在3行之后，我已经指示将当前文件保存为新文件，并再次打开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


     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

---

你能在代码中实现吗？我很难实现。你能在代码中实现吗？我很难实现。嗨，大卫，非常感谢你的努力。但是这一行有一个问题，`wdDoc.shapeText-Box&i.TextFrame.TextRange.Text=\uu.Cellsr，col.Value`请看，我不知道如何手动更改文本框的名称您想更改文本框的名称还是文本？再看看你的代码…我只想用24个3行x 8列单元格内容填充word中的所有24个文本框，所以我必须将每个单元格文本放在word的单个文本框中。然后用唯一的名称保存它，然后再次打开删除文本框中的所有文本，并用下一批3行填充。好的，所以没有任何关于更改文本框名称的内容，只是内容文本。你的代码适合这个工作，我测试了它，它工作了…好的，但问题是它只对第一批的3行进行了操作，它没有用名称保存它，然后在接下来的3行中再次填充。David非常感谢你的努力。但是这一行有一个问题，`wdDoc.shapeText-Box&i.TextFrame.TextRange.Text=\uu.Cellsr，col.Value`请看，我不知道如何手动更改文本框的名称您想更改文本框的名称还是文本？再看看你的代码…我只想用24个3行x 8列单元格内容填充word中的所有24个文本框，所以我必须将每个单元格文本放在word的单个文本框中。然后用唯一的名称保存它，然后再次打开删除文本框中的所有文本，并用下一批3行填充。好的，所以没有任何关于更改文本框名称的内容，只是内容文本。你的代码适合这个工作，我测试了它，它工作了…好的，但问题是它只对第一批3行进行了操作，它没有用名称保存它，然后再次填充接下来的3行