Word Table importing Problem..

vaxo
3StarLounger
Posts: 383
Joined: 23 Mar 2017, 19:51

Word Table importing Problem..

Post by vaxo »

Hello friends, I have this macro for table importing, but it imports not all tables from word documents, sometimes it imports but with Microsoft word objects in minor cases, and sometimes it gets this message and stops importing: Method 'Pasetespecial" of object _Worksheet' failed.

Please help solve this problem.

Code: Select all

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

    tableTot = wdDoc.Tables.Count
    If tableTot = 0 Then
        MsgBox "This document contains no tables", vbExclamation, "Import Word Table"
    ElseIf tableTot > 1 Then
        tableStart = InputBox("This Word document contains " & tableTot & " tables." & vbCrLf & _
        "Enter the table to start from", "Import Word Table", "1")
    End If

    resultRow = 4

    For tableNo = tableStart To tableTot
        Set wSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        wdDoc.Tables(tableNo).Range.Copy
        wSheet.Cells(resultRow, 1).Select
        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

User avatar
Jay Freedman
Microsoft MVP
Posts: 1211
Joined: 24 May 2013, 15:33
Location: Warminster, PA

Re: Word Table importing Problem..

Post by Jay Freedman »

I see one possible point of failure, but I'm not sure whether it has anything to do with the error you mentioned.

Because of this section of the code

tableTot = wdDoc.Tables.Count
If tableTot = 0 Then
MsgBox "This document contains no tables", vbExclamation, "Import Word Table"
ElseIf tableTot > 1 Then
tableStart = InputBox("This Word document contains " & tableTot & " tables." & vbCrLf & _
"Enter the table to start from", "Import Word Table", "1")
End If

the variable tableStart is not explicitly initialized to 1 if there is exactly one table in the document. That causes VBA to initialize it silently to 0. Then the For loop starts with tableNo = 0, which is not a valid index into the Tables collection. I suggest that you insert

Else
tableTot = 1

just before the End If statement.

User avatar
HansV
Administrator
Posts: 75203
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Word Table importing Problem..

Post by HansV »

Could you attach a sample Word document (without sensitive information) for which the macro produces an incomplete or incorrect result?
Regards,
Hans

vaxo
3StarLounger
Posts: 383
Joined: 23 Mar 2017, 19:51

Re: Word Table importing Problem..

Post by vaxo »

The file is to large for there attachment how to attache in a different way?

vaxo
3StarLounger
Posts: 383
Joined: 23 Mar 2017, 19:51

Re: Word Table importing Problem..

Post by vaxo »


User avatar
HansV
Administrator
Posts: 75203
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Word Table importing Problem..

Post by HansV »

It appears to be a timing problem - when I run the code multiple times, it errors at different tables, or sometimes not at all.
Adding a DoEvents line works well for me. I also added Jay Freedman's suggestion (thanks, Jay!)

Code: Select all

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

    tableTot = wdDoc.Tables.Count
    If tableTot = 0 Then
        MsgBox "This document contains no tables", vbExclamation, "Import Word Table"
    ElseIf tableTot > 1 Then
        tableStart = InputBox("This Word document contains " & tableTot & " tables." & vbCrLf & _
        "Enter the table to start from", "Import Word Table", "1")
    Else
        tableTot = 1
    End If

    resultRow = 4

    For tableNo = tableStart To tableTot
        Set wSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        wdDoc.Tables(tableNo).Range.Copy
        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
Regards,
Hans

vaxo
3StarLounger
Posts: 383
Joined: 23 Mar 2017, 19:51

Re: Word Table importing Problem..

Post by vaxo »

No, it stops working, as in previous codes :(

vaxo
3StarLounger
Posts: 383
Joined: 23 Mar 2017, 19:51

Re: Word Table importing Problem..

Post by vaxo »

It stops working not importing whole tables, besides this document has more then 29 table.
You do not have the required permissions to view the files attached to this post.

vaxo
3StarLounger
Posts: 383
Joined: 23 Mar 2017, 19:51

Re: Word Table importing Problem..

Post by vaxo »

Maybe this is the problem: "wdFileName = Application.GetOpenFilename("Word files (*.doc*),*.doc*", , _" as the document extension is "docx".?

vaxo
3StarLounger
Posts: 383
Joined: 23 Mar 2017, 19:51

Re: Word Table importing Problem..

Post by vaxo »

pircutre 2.png
For example the tables is never imported
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 75203
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Word Table importing Problem..

Post by HansV »

Strange - the macro says that the document contains 29 tables, but Word itself says that there are 33 tables...
Is this better?

Code: Select all

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
Regards,
Hans

vaxo
3StarLounger
Posts: 383
Joined: 23 Mar 2017, 19:51

Re: Word Table importing Problem..

Post by vaxo »

Yeses, it seems works, Big big Thanks.

snb
3StarLounger
Posts: 263
Joined: 14 Nov 2012, 16:06

Re: Word Table importing Problem..

Post by snb »

No problems with:

Code: Select all

Sub M_snb()
  With Application.FileDialog(3)
    .InitialFileName = "*.doc*"
    If .Show Then
      With GetObject(.SelectedItems(1))
        Sheets.Add , Sheets(Sheets.Count), .tables.Count
        For Each it In .tables
          n = n + 1
          it.Range.Copy
          Sheets(n + 1).Paste Sheets(n + 1).Cells(1)
        Next
        .Close 0
      End With
    End If
  End With
End Sub