Question

我正在尝试自动化将数据从可填充的Word文档追加到Excel工作表的过程。
这是我的代码：

Sub Test()  
Dim txt As String  
Dim objWrd  
Dim objDoc  
Dim objSelection  
Dim varResult As Variant  
Dim msgValue  
Dim dlgOpen As FileDialog  
Dim lngCount As Long  
Dim fNames As New Collection  
Dim rng As Range  
Dim ws As Worksheet  
Dim i As Long, j As Long, RowCounter As Long: RowCounter = 2  

Set ws = ActiveWorkbook.Worksheets("RiskManagement")  

Dim art, adtOcc, atm, acounty, adet, aatt, aloc, bdob, bsex, bvehType, bstblts As String  


Set dlgOpen = Application.FileDialog( _  
 FileDialogType:=msoFileDialogOpen)  
 With dlgOpen  
 .AllowMultiSelect = True  
 .Show  
End With  

 For lngCount = 1 To dlgOpen.SelectedItems.Count  
fNames.Add (dlgOpen.SelectedItems(lngCount))  
 Next lngCount  


Set objWrd = CreateObject("word.Application")  
For x = 1 To lngCount  
Set objDoc = objWrd.documents.Open(fNames(x))  

Set rng = ws.Range("a" & ws.Rows.Count).End(xlUp).Offset(1, 0)  
If rng.Row < 2 Then  
Set rng = ws.Range("a2")  
End If  
objWrd.ActiveDocument.Visible = false  
Set objSelection = objWrd.Selection  
art = objWrd.ActiveDocument.FormFields("drpIncidentType").Result'<<    
adtOcc = objWrd.ActiveDocument.FormFields("txtDateOccured").Result  
atm = objWrd.ActiveDocument.FormFields("txtTimeOccured").Result  
acounty = objWrd.ActiveDocument.FormFields("txtCountyCode").Result  
adet = objWrd.ActiveDocument.FormFields("txtEmployeeType").Result  
aatt = objWrd.ActiveDocument.FormFields("drpAttachment").Result  
aloc = objWrd.ActiveDocument.FormFields("txtLoc").Result  
bdob = objWrd.ActiveDocument.FormFields("txtDriverDOB").Result  
bsex = objWrd.ActiveDocument.FormFields("drpDriverGender").Result  
bvehType = objWrd.ActiveDocument.FormFields("txtVehicleType").Result  
bstblts = objWrd.ActiveDocument.FormFields("drpSeatbelts").Result  

RowCounter = ws.UsedRange.Count + 1  


ws.Cells(RowCounter, 1) = art  

ws.Cells(RowCounter, 2) = adtOcc  

ws.Cells(RowCounter, 3) = atm  

ws.Cells(RowCounter, 4) = acounty  

ws.Cells(RowCounter, 5) = adet  

ws.Cells(RowCounter, 6) = aatt  

ws.Cells(RowCounter, 7) = aloc  

ws.Cells(RowCounter, 8) = bdob  

ws.Cells(RowCounter, 9) = bsex  

ws.Cells(RowCounter, 10) = bvehType  

ws.Cells(RowCounter, 11) = bstblts  



objWrd.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges  
Set objWrd = Nothing  
Next x  





End Sub

运行上面的代码时，出现以下错误：

应用定义错误或对象定义错误

在上述代码中的

注释为<<的行上

art = objWrd.ActiveDocument.FormFields("drpIncidentType").Result

关于为什么会出现该错误以及如何实现我要做什么的任何想法？

Here是我正在处理的报告的示例

更新：
这是更新的代码：

Sub Test()  
Application.ScreenUpdating = False  

Dim objWrd As Object  
Dim objDoc As Object  

Dim ws As Worksheet  
Dim lngCount As Long, RowCounter As Long, x As Long  
Dim fNames As New Collection  
Dim fd As Office.FileDialog  

Set ws = ActiveWorkbook.Worksheets("RiskManagement")  
RowCounter = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row  

Set fd = Application.FileDialog(msoFileDialogFilePicker)  
With fd  
 .AllowMultiSelect = True  
 .Show  
 For lngCount = 1 To .SelectedItems.Count  
  fNames.Add .SelectedItems(lngCount)  
 Next lngCount  
If (.SelectedItems.Count = 0) Then  

Else  


Set objWrd = CreateObject("word.Application")  

With objWrd  
  .Visible = False  
  If (fNames.Count = 0) Then  
  Exit Sub  
  Else  

Dim WDR As Range  
  For x = 1 To lngCount  
    RowCounter = RowCounter + 1  

    Set objDoc = objWrd.Documents.Open(fNames(x))  


    With objDoc  
   MsgBox .Selection.FormFields(1).Result  <<

      ws.Cells(RowCounter, 1) = .ActiveDocument.FormFields("drpIncidentType").DropDown.Value  
      ws.Cells(RowCounter, 2) = .FormFields("txtDateOccured").Result  
      ws.Cells(RowCounter, 3) = .FormFields("txtTimeOccured").Result  
      ws.Cells(RowCounter, 4) = .FormFields("txtCountyCode").Result  
      ws.Cells(RowCounter, 5) = .FormFields("txtEmployeeType").Result  
      ws.Cells(RowCounter, 6) = .FormFields("drpAttachment").Result  
      ws.Cells(RowCounter, 7) = .FormFields("txtLoc").Result  
      ws.Cells(RowCounter, 8) = .FormFields("txtDriverDOB").Result  
      ws.Cells(RowCounter, 9) = .FormFields("drpDriverGender").Result  
      ws.Cells(RowCounter, 10) = .FormFields("txtVehicleType").Result  
      ws.Cells(RowCounter, 11) = .FormFields("drpSeatbelts").Result  
      .Close False  
    End With  
  Next  
  .Quit  
  End If  
End With  



objDoc.Close SaveChanges:=wdDoNotSaveChanges  
Set objDoc = Nothing: Set objWrd = Nothing  
Application.ScreenUpdating = True  
End If  
End With  
End Sub

我现在得到的唯一错误是：
服务器抛出异常

它发生在objDoc with子句中的第一次调用中。我已经尝试了一系列不同的Selections，Document和FormFields变体，但是它总是抛出相同的错误

Answer 1

您的for循环中有Set ObjWrd = Nothing（一直在底部）

我相信您打算在那里ObjDoc

Answer 2

除了循环内错误且不必要的'Set ObjWrd = Nothing'外，您的代码还很混乱。您有许多未使用，未声明和未声明的变量以及不必要的变量。此外，尽管为后期绑定而编写，但是您的代码使用的Word常量仅适用于早期绑定。试试：

Sub Test()
Application.ScreenUpdating = False
Dim objWrd As Object, objDoc As Object
Dim ws As Worksheet
Dim lngCount As Long, RowCounter As Long, x As Long
Dim fNames As New Collection

Set ws = ActiveWorkbook.Worksheets("RiskManagement")
RowCounter = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row

With Application.FileDialog(msoFileDialogOpen)
 .AllowMultiSelect = True
 .Show
 For lngCount = 1 To .SelectedItems.Count
  fNames.Add .SelectedItems(lngCount)
 Next lngCount
End With

Set objWrd = CreateObject("word.Application")
With objWrd
  .Visible = False
  For x = 1 To lngCount
    RowCounter = RowCounter + 1
    Set objDoc = objWrd.Documents.Open(fNames(x), , True, False, , , , , , , , False)
    With objDoc
      ws.Cells(RowCounter, 1) = .FormFields("drpIncidentType").Result
      ws.Cells(RowCounter, 2) = .FormFields("txtDateOccured").Result
      ws.Cells(RowCounter, 3) = .FormFields("txtTimeOccured").Result
      ws.Cells(RowCounter, 4) = .FormFields("txtCountyCode").Result
      ws.Cells(RowCounter, 5) = .FormFields("txtEmployeeType").Result
      ws.Cells(RowCounter, 6) = .FormFields("drpAttachment").Result
      ws.Cells(RowCounter, 7) = .FormFields("txtLoc").Result
      ws.Cells(RowCounter, 8) = .FormFields("txtDriverDOB").Result
      ws.Cells(RowCounter, 9) = .FormFields("drpDriverGender").Result
      ws.Cells(RowCounter, 10) = .FormFields("txtVehicleType").Result
      ws.Cells(RowCounter, 11) = .FormFields("drpSeatbelts").Result
      .Close False
    End With
  Next
  .Quit
End With
Set objDoc = Nothing: Set objWrd = Nothing
Application.ScreenUpdating = True
End Sub

Answer 3

我会这样做。

Sub WordToExcel()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim x As Integer
Dim strFilename As String
Dim strFolder As String
Dim temp As String

Set wdApp = New Word.Application
'initialise counter
x = 1
'search for first file in directory
strFolder = "C:\Test\"
strFilename = Dir(strFolder & "*.doc")
'amemd folder name
Do While strFilename <> ""
Set wdDoc = wdApp.Documents.Open(strFolder & strFilename)
temp = wdDoc.Tables(1).Cell(2, 1).Range.Text 'read word cell
Range("A2").Offset(x, 0) = temp
temp = wdDoc.Tables(1).Cell(2, 2).Range.Text 'read word cell
Range("A2").Offset(x, 1) = temp
'etc
temp = wdDoc.Tables(1).Cell(2, 3).Range.Text 'read word cell
Range("A2").Offset(x, 2) = temp
temp = wdDoc.Tables(1).Cell(2, 4).Range.Text 'read word cell
Range("A2").Offset(x, 3) = temp

wdDoc.Close
x = x + 1
strFilename = Dir
Loop
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub

使用Excel打开多个Word文档并导入数据

3 个答案: