Populate textboxes in Word from Excel

Question

I have 24 Textbox in a word Document as shown in the picture Below:

Which I am trying to populate using the content from each cell from the below range in a worksheet as shown below:

Three Rows at a time: Because there are 24 textboxes so 3 Rows and 8 Columns will have 24 Cells each time:

I would then Save it with a unique name and Make New from the next 3 Rows:

Code:

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

What I don't know:

1. How to rename a textbox (manually or by code) in the word document so that in can be used in the macro.

2. Save the word document and Create New Word Doc with 24 TextBoxes so that they can be filled again.

Answer 1

1. Code to rename textBox1 as textBox2:

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

without first selecting the textBox (or any other shape for that matter) , you can't modify its name.

2. You've already done that in the code, just re-use the line:

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

..to open a new file and to start over. Make sure you close the documents which you don't need anymore, or you'll end up with 24 open documents. I don't think you need that.

Answer 2

For your request I've modified your code. I couldn't test it myself, since there are variables that are not accessible to me (Path, Folder) so if does not compile and work, just look and what I've done near the end and try to modify yourself.

basically, after 3 lines I've instructed to save the current file as new, and open the 24-blank-textboxes file again, which will be saved again after 3 lines etc'...

BTW, you mentioned you wanted to change the name of a textBox, but there is nothing about it in your code. If you want to do it you will need to write us more code about it.

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