Consulting

Results 1 to 4 of 4

Thread: Transfer Data in Excel to Word have Checkbox Content Control

  1. #1
    VBAX Newbie
    Joined
    Sep 2020
    Posts
    3
    Location

    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!
    Map.jpg
    Attached Files Attached Files

  2. #2
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Newbie
    Joined
    Sep 2020
    Posts
    3
    Location
    Quote Originally Posted by gmayor View Post
    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"

  4. #4
    VBAX Newbie
    Joined
    Sep 2020
    Posts
    3
    Location
    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
    Last edited by toangm; 09-06-2020 at 07:40 AM.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •