excel visual basic收集 word 数据

打开Excel 2013，进入“开发工具—VBA”（开发工具需要在 “文件----选项---自定义功能区 ”  添加），新建模块，编写程序。

参考代码如下：

'在“工具—引用”中勾选“Microsoft Word ##.# Object Library”

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