Populate textboxes in Word from Excel - vba

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:
How to rename a textbox (manually or by code) in the word document so that in can be used in the macro.
Save the word document and Create New Word Doc with 24 TextBoxes so that they can be filled again.

Answer 1

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

Answer 2

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.
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.