Hello Friends, I have code for extracting word tables to excel sheets.. but it stops working after extracting some tables. Code is this:

The error alert says: Methos Pastespecial of object_Worksheet failed.

Please help...


Sub ImportWordTables()
Dim wdApp As Object
Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Long
Dim tableStart As Long
Dim tableTot As Long
Dim resultRow As Long
Dim fStart As Boolean
Dim wSheet As Worksheet

wdFileName = Application.GetOpenFilename("Word files (*.doc*),*.doc*", , _
"Browse for file containing table to be imported")

If wdFileName = False Then Exit Sub '(user cancelled import file browser)

On Error Resume Next
Set wdApp = GetObject(Class:="Word.Application")
If wdApp Is Nothing Then
Set wdApp = CreateObject(Class:="Word.Application")
fStart = True
End If
On Error GoTo ErrHandler

Set wdDoc = wdApp.Documents.Open(Filename:=wdFileName) 'open Word file

' Repetition to force Word to calculate the correct count
tableTot = wdDoc.Tables.Count
tableTot = wdDoc.Tables.Count
tableTot = wdDoc.Tables.Count
If tableTot = 0 Then
MsgBox "This document contains no tables", vbExclamation, "Import Word Table"
ElseIf tableTot > 1 Then
tableStart = Val(InputBox("This Word document contains " & tableTot & " tables." & vbCrLf & _
"Enter the table to start from", "Import Word Table", "1"))
If tableStart < 1 Then
Beep
Exit Sub
End If
Else
tableStart = 1
End If

resultRow = 4

For tableNo = tableStart To tableTot
Set wSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count) )
wSheet.Name = "Table " & tableNo
wdDoc.Tables(tableNo).Range.Copy
DoEvents
wSheet.Cells(resultRow, 1).Select
DoEvents
wSheet.PasteSpecial Format:="HTML"
Next tableNo

ExitHandler:
On Error Resume Next
wdDoc.Close SaveChanges:=False
If fStart Then
wdApp.Quit SaveChanges:=False
End If
Exit Sub

ErrHandler:
MsgBox Err.Description, vbExclamation, "Import Word Table"
Resume ExitHandler
End Sub