Transfer Data in Excel to Word have Checkbox Content Control

[toangm]

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!
27067

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


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

[toangm]

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.


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"

[toangm]

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