从Excel中填充Word中的文本框

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

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

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

然后我会用一个独特的名字保存它，并从接下来的3行中进行新build：

码：

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文档中重命名文本框（手动或通过代码），以便在macros中使用。

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

Answer 1

为了您的请求，我修改了您的代码。 我无法自己testing，因为有些variables是我无法访问的（path，文件夹），所以如果不能编译和工作，只要看看我在结尾做了些什么，然后尝试修改自己。

基本上，我已经指示将当前文件保存为新的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" 

没有首先select文本框（或任何其他形状），你不能修改它的名字。

2. 你已经在代码中完成了，只需重新使用这一行：

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

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