使用Word上的VBA将数据从Word表单导出到Excel在线表的新行

Question

我想创建一个每天完成的Word表单文档，并将数据导出到我在sharepoint中的Excel表。我的计划是在调查的底部有一个按钮，运行一个宏。这个宏将把word表单文档中的所有数据发送到要存储的excel的新行。它本质上与此相同:https://www.techrepublic.com/blog/10-things/10-steps-to-transferring-word-form-data-to-an-excel-sheet/然而，这个指南已经过时了，我在"cnn.close"上运行了一个问题。它给了我一个&quot对象变量或&quot块变量不设置"运行错误(91)。任何帮助都将是非常感激的，我已经绞尽脑汁几个星期试图找到一个解决方案。谢谢你！

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:ExamplesSales.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

有很多方法可以做到这一点。这里有一个选项。

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