Sub ColumnToPDF()
'Graham Mayor - https://www.gmayor.com - 21 September 2023

Dim oTable As Table
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)
    oTable.Columns(1).Select
    Selection.Copy
    Set oNew = Documents.Add
    Set oRng = oNew.Range
    oRng.Paste
    Debug.Print 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