Transfer Data in Excel to Word have Checkbox Content Control

[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