Word Table importing Problem..

[HansV]

Sorry, I didn't notice.
The code runs without error for me. It reports that the document contains 27 tables, and it creates 27 sheets:

S2236.png

Do you know at which table it fails for you?

[vaxo]

It varies, sometimes Table 5, sometimes Table 13 and so on...

[vaxo]

And quick question, should excel clipboard copy all information from copying from an external sources? Or does it some problem?

11.PNG

[HansV]

That still sounds like a timing problem. Here is a slight variation (using a line from snb's reply):

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))
        DoEvents
        wSheet.Name = "Table " & tableNo
        DoEvents
        wdDoc.Tables(tableNo).Range.Copy
        DoEvents
        wSheet.Paste Destination:=wSheet.Range("A1")
        DoEvents
    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

[HansV]

I don't know whether the clipboard causes the problem,,,

[vaxo]

No, still does not working :(

[HansV]

Do you have a slow computer, or one with little RAM?

[vaxo]

No 16 Ram Thinkpad.

[vaxo]

Microsoft Office LTSC Professional Plus 2021 - office version.

[HansV]

Very strange. Could you test the macro on another computer - of a friend or colleague?

[vaxo]

Ok, I would try tomorrow... and it works in your computer?

[HansV]

Yes, I have run the code several times. It runs without error every time.

[vaxo]

Yes, it works on different laptop... Could it be problem of version of office?

[HansV]

No, I don't think the version of Office would make a difference - the code uses pretty standard VBA commands that work in all versions.

You could try to repair your Office installation, but I cannot guarantee that it will solve the problem...