Transfer Data in Excel to Word have Checkbox Content Control

Hi!
I have 2 file include(01: Excel Data, 02: Word Template)
I need help export data from excel to Word template
Help me Write code VBA Excel -> Result: Report have Checkbox Content Control

Thanks!
Attachment 27067

Change the two text items in the document for rich text content controls titled Name and Tel
Save the document in the same folder as the workbook
Add the following code to the worksheet module
Assign the code to the button.

Code:

---

Option Explicit

Sub Macro1()
'Graham Mayor - https://www.gmayor.com - Last updated - 04 Sep 2020
Dim wdApp As Object
Dim wdDoc As Object
Dim oCC As Object
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    ThisWorkbook.Save
    Set wdDoc = wdApp.Documents.Add(Template:=ThisWorkbook.Path & "\Template.docx")
    For Each oCC In wdDoc.contentcontrols
        Select Case oCC.Title
            Case "ckMale"
                If Range("B3") = 1 Then
                    oCC.Checked = True
                Else
                    oCC.Checked = False
                End If
            Case "ckFemale"
                If Range("B4") = 1 Then
                    oCC.Checked = True
                Else
                    oCC.Checked = False
                End If
            Case "ckNew"
                If Range("B5") = 1 Then
                    oCC.Checked = True
                Else
                    oCC.Checked = False
                End If
            Case "ckFix"
                If Range("B6") = 1 Then
                    oCC.Checked = True
                Else
                    oCC.Checked = False
                End If
            Case "Name"
                oCC.Range.Text = Range("B2")
            Case "Tel"
                oCC.Range.Text = Range("B7")
        End Select
    Next oCC
lbl_Exit:
    Set oCC = Nothing
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Exit Sub
End Sub

---

Quote:

---

Originally Posted by gmayor

Change the two text items in the document for rich text content controls titled Name and Tel
Save the document in the same folder as the workbook
Add the following code to the worksheet module
Assign the code to the button.

Code:

---

Option Explicit

Sub Macro1()
'Graham Mayor - https://www.gmayor.com - Last updated - 04 Sep 2020
Dim wdApp As Object
Dim wdDoc As Object
Dim oCC As Object
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0
    ThisWorkbook.Save
    Set wdDoc = wdApp.Documents.Add(Template:=ThisWorkbook.Path & "\Template.docx")
    For Each oCC In wdDoc.contentcontrols
        Select Case oCC.Title
            Case "ckMale"
                If Range("B3") = 1 Then
                    oCC.Checked = True
                Else
                    oCC.Checked = False
                End If
            Case "ckFemale"
                If Range("B4") = 1 Then
                    oCC.Checked = True
                Else
                    oCC.Checked = False
                End If
            Case "ckNew"
                If Range("B5") = 1 Then
                    oCC.Checked = True
                Else
                    oCC.Checked = False
                End If
            Case "ckFix"
                If Range("B6") = 1 Then
                    oCC.Checked = True
                Else
                    oCC.Checked = False
                End If
            Case "Name"
                oCC.Range.Text = Range("B2")
            Case "Tel"
                oCC.Range.Text = Range("B7")
        End Select
    Next oCC
lbl_Exit:
    Set oCC = Nothing
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Exit Sub
End Sub

---

---

Thank you very much!
But I have multi value in row at colum A in "Excel_Data_Run_Macro.xlsm". I want type as "loop" don't use "Select Case"

Help me edit code below: It working but I don't use Select case



Option Explicit

Sub Macro2()
Application.ScreenUpdating = False
'Graham Mayor - https://www.gmayor.com - Last updated - 04 Sep 2020
Dim wdApp As Object
Dim wdDoc As Object
Dim oCC As Object
Dim rngSH As Range
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0

Worksheets("sheet1").Activate
wdApp.Visible = True

Set wdDoc = wdApp.Documents.Open(ThisWorkbook.Path & "\Template.docx")
wdApp.Documents(ThisWorkbook.Path & "\Template.docx").SaveAs Filename:=ThisWorkbook.Path & "\Result.docx"
For Each oCC In wdDoc.contentcontrols
Select Case oCC.Title
Case "ckMale"
If Range("B3") = 1 Then
oCC.Checked = True
Else
oCC.Checked = False
End If
Case "ckFemale"
If Range("B4") = 1 Then
oCC.Checked = True
Else
oCC.Checked = False
End If
Case "ckNew"
If Range("B5") = 1 Then
oCC.Checked = True
Else
oCC.Checked = False
End If
Case "ckFix"
If Range("B6") = 1 Then
oCC.Checked = True
Else
oCC.Checked = False
End If

End Select
Next oCC


For Each rngSH In Sheets("Sheet1").Range([A2], [A65000].End(3))
wdApp.Selection.Find.Execute rngSH, , , , , , , , , Sheets("Sheet1").Range(rngSH(1, 2).Address(0, 0)), 2
Next
wdApp.Documents.Save

lbl_Exit:
Set oCC = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
Exit Sub

Application.ScreenUpdating = True
End Sub