Sub CellToPDF()
'Graham Mayor - https://www.gmayor.com - 04 May 2023 

Dim oTable As Table
Dim oCell As Cell
Dim oRng As Range
Dim oDoc As Document, oNew As Document
Dim intPos As Integer
Dim strDocName As String
Const strPath As String = "C:\path\" 'the path where the document is to be saved
    
    If ActiveDocument.Tables.Count < 2 Then GoTo lbl_Exit
        
    Set oDoc = ActiveDocument
Start:
    strDocName = oDoc.Name
    intPos = InStrRev(strDocName, ".")
    If intPos = 0 Then
        oDoc.Save
        GoTo Start
    End If
    strDocName = Left(strDocName, intPos - 1)
    strDocName = strPath & strDocName & ".pdf"

    Set oTable = ActiveDocument.Tables(2)
    Set oCell = oTable.Cell(2, 1)
    oCell.Select
    Selection.Copy
    Set oNew = Documents.Add
    Set oRng = oNew.Range
    oRng.Paste
    Debug.Print strPath & strDocName
    oNew.ExportAsFixedFormat OutputFileName:=strDocName, ExportFormat:=wdExportFormatPDF, _
                                       OpenAfterExport:=False, _
                                       OptimizeFor:=wdExportOptimizeForPrint, _
                                       Range:=wdExportAllDocument, From:=1, To:=1, _
                                       Item:=wdExportDocumentContent, _
                                       IncludeDocProps:=True, _
                                       KeepIRM:=True, _
                                       CreateBookmarks:=wdExportCreateHeadingBookmarks, _
                                       DocStructureTags:=True, _
                                       BitmapMissingFonts:=True, _
                                       UseISO19005_1:=False
    oNew.Close 0
lbl_Exit:
    Exit Sub
End Sub