Exporting Data from Word Form to a new row on Excel Online Table Using VBA on word

Question

I want to create a Word form document that is completed daily and exports data to an Excel table I have in a sharepoint. My plan is to have a button at the bottom of the survey that runs a macro. This macro would send all data in the word form document to a new row of the excel to be stored. It's essentially the same as this: https://www.techrepublic.com/blog/10-things/10-steps-to-transferring-word-form-data-to-an-excel-sheet/ However, this guide is outdated and I run an issue at the "cnn.close" where it gives me an "Object Variable or With block variable not set" run-time error (91). Any help would be appreciated, I've been hitting my head for a few weeks trying to find a solution. Thank you!

Sub TransferToExcel()
'Transfer a single record from the form fields to an Excel workbook.
  Dim doc As Document
  Dim strCompanyName As String
  Dim strPhone As String
  Dim strSQL As String
  Dim cnn As ADODB.Connection
  'Get data.
  Set doc = ActiveDocument 'ThisDocument
  On Error GoTo ErrHandler
  strCompanyName = Chr(39) & doc.FormFields("txtCompanyName").Result & Chr(39)
  strPhone = Chr(39) & doc.FormFields("txtPhone").Result & Chr(39)
  'Define sql string used to insert each record in the destination workbook.
  'Don't omit the $ in the sheet identifier.
  strSQL = "INSERT INTO [PhoneList$]" _
    & " (CompanyName, Phone)" _
    & " VALUES (" _
    & strCompanyName & ", " _
    & strPhone _
    & ")"
  Debug.Print strSQL
  'Define connection string and open connection to destination workbook file.
  Set cnn = New ADODB.Connection
  With cnn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .ConnectionString = "Data Source=E:\Examples\Sales.xlsx;" & _
      "Extended Properties=Excel 8.0;"
    .Open
    'Transfer data.
    .Execute strSQL
  End With
  Set doc = Nothing
  Set cnn = Nothing
  Exit Sub
ErrHandler:
  MsgBox Err.Number & ": " & Err.Description, _
    vbOKOnly, "Error"
  On Error GoTo 0
  On Error Resume Next
  cnn.Close
  Set doc = Nothing
  Set cnn = Nothing
End Sub

Answer 1

There are so many ways to do this. Here's one option.

Option Base 1

Public UseCol
Public WhichCol
Public SArr As Variant
Public PasteRow
Public CompareTitleArray As Variant


Sub Pull_Quality_SelfAudit_Data()
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Dim wTable As Word.Table
    Dim tRangeText As String, tRange As Word.Range
    Dim p As Long, r As Long
    Dim LastColumn As Long
    Dim sht As Worksheet

    If WorksheetFunction.CountA(Cells) > 0 Then
        'Search for any entry, by searching backwards by Columns.
        LastColumn = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        'MsgBox LastColumn
    End If

    CompareTitleArray = Sheet1.Range("A1:IU1").Value
   
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = False
        .Show
        strPath = .SelectedItems(1)
    End With
   
    Set wrdApp = CreateObject("Word.Application")
    wrdApp.Visible = True
    Set wrdDoc = wrdApp.Documents.Open(strPath)

    WhichCol = 0
'    desrt = Sheet1.Cells.Find(What:="*", After:=sht.Range("A1"), LookAt:=xlPart, _
'                         LookIn:=xlFormulas, SearchOrder:=xlByRows, _
'                         SearchDirection:=xlPrevious, MatchCase:=False).Row
    'Set sht = Sheet1
    'Find_Last (Sheet1)
    'PasteRow = Find_Last(Sheet1) + 1
    'never start on Row 1 or it will overwrite the titles
    PasteRow = Application.WorksheetFunction.Max(Find_Last(Sheet1) + 1, 2)
   
   
    Dim ffld As Word.FormField
    For Each ffld In wrdDoc.FormFields
        TargetCol = Application.Match(ffld.Name, CompareTitleArray, 0)
'        WhichCol = WhichCol + 1
'        ConvertCol (WhichCol)
        If IsError(TargetCol) Then
            LastCol = LastCol + 1 'increment to next blank column header
            CompareTitleArray(1, LastCol) = ffld.Name
            TargetCol = LastCol 'use this column to paste in data
            ConvertCol (TargetCol)
            Sheet1.Range(UseCol & "1").Value = ffld.Name
        Else
            ConvertCol (TargetCol)
        End If
        'Debug.Print ffld.Name & "   " & ffld.Result
        'sdf = "ewwe"
        Sheet1.Range(UseCol & PasteRow).Value = ffld.Result
    Next
   
    MsgBox "Done", , "Processing completed"
   
End Sub


Private Function Find_Last(sht As Worksheet)
'Find_Last = 0
On Error Resume Next
Find_Last = sht.Cells.Find(What:="*", After:=sht.Range("A1"), LookAt:=xlPart, _
                         LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                         SearchDirection:=xlPrevious, MatchCase:=False).Row
On Error GoTo 0
If IsEmpty(Find_Last) Then Find_Last = 1
End Function

Private Function ConvertCol(SourceNum)
   
    MyColNum = SourceNum
    '==================================================================
    'Translate Column header to usable letter as UseCol

    ColMod = MyColNum Mod 26    'div column # by 26.  Remainder is the second letter
    If ColMod = 0 Then          'if no remainder then fix value
        ColMod = 26
        MyColNum = MyColNum - 26
    End If
    intInt = MyColNum \ 26      'first letter
    If intInt = 0 Then UseCol = Chr(ColMod + 64) Else _
    UseCol = Chr(intInt + 64) & Chr(ColMod + 64)
    '==================================================================

End Function