Sub GetExcelData()
Application.ScreenUpdating = False
'Note: A VBA Reference to the Excel Object Model is required, via Tools|References
Dim xlApp As New Excel.Application, xlWkBk As Excel.Workbook, xlWkSht As Excel.Worksheet
Dim StrWkBkNm As String, i As Long, j As Long, r As Long
StrWkBkNm = ThisDocument.Path & "\Data to fill.xlsx"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
With xlApp
  .Visible = False
  .DisplayAlerts = False
  Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMRU:=False)
End With
Set xlWkSht = xlWkBk.Worksheets("Sheet1")
With ActiveDocument
  For i = 1 To .Tables.Count
    r = i + 1
    With .Tables(i)
      .Cell(2, 2).Range.Text = "PV: " & xlWkSht.Range("B" & r).Value
      With .Cell(3, 2).Range
        .ContentControls(1).Checked = (xlWkSht.Range("F" & r).Value = "Y")
        .ContentControls(2).Checked = (xlWkSht.Range("F" & r).Value = "Y")
        .ContentControls(3).Checked = (xlWkSht.Range("G" & r).Value = "Y")
      End With
      With .Cell(3, 1).Range
        With .ContentControls(1)
          .Type = wdContentControlText
          .Range.Text = xlWkSht.Range("A" & r).Value
          .Type = wdContentControlDropdownList
        End With
        With .ContentControls(2)
          .Type = wdContentControlText
          .Range.Text = xlWkSht.Range("D" & r).Value
          .Type = wdContentControlDropdownList
        End With
        With .ContentControls(3)
          .Type = wdContentControlText
          .Range.Text = xlWkSht.Range("C" & r).Value
          .Type = wdContentControlDropdownList
        End With
      End With
    End With
  Next
End With
xlWkBk.Close False
xlApp.Quit
Set xlWkSht = Nothing: Set xlWkBk = Nothing: Set xlApp = Nothing
Application.ScreenUpdating = True
End Sub