Question

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

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

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

然后我会用一个唯一的名字保存它，并从接下来的3行中使用Make：

代码：

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

我不知道的是：

如何在word文档中重命名文本框（手动或按代码），以便可以在宏中使用。
保存单词文档并使用24个文本框创建新的Word文档，以便可以再次填充它们。

Answer 1

将textBox1重命名为textBox2的代码：

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

没有先选择textBox（或任何其他形状），您就无法修改其名称。

您已经在代码中完成了这项操作，只需重复使用该行：
```
Set wdDoc = wdApp.Documents.Open(Path & "\" & Folder & "\" & File)
```

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

Answer 2

根据您的要求，我修改了您的代码。我自己无法测试它，因为有些变量是我无法访问的（路径，文件夹）所以如果不编译和工作，只需看看我在最后做了什么并尝试修改自己。

基本上，经过3行后，我已指示将当前文件保存为新文件，然后再次打开24-blank-textboxes文件，这将在3行等后再次保存＆＃39; ...

顺便说一下，你提到你想改变一个textBox的名字，但你的代码中没有任何关于它的内容。如果你想这样做，你需要写一些关于它的代码。

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

从Excel填充Word中的文本框

2 个答案: