Copy first table from word document to an excel using excel macro VBA

Question

I am newbie to Excel Macro and VBA.

I have a requirement to copy the table data from a word document to an excel sheet using macro VBA.

I need document V1.2 version to be executed among many version of documents in a specific folder. For ex: I have documents "C:\\Test\\FirstDocV1.1.doc" & "C:\\Test\\FirstDocV1.2.doc" .

I want only "C:\\Test\\FirstDocV1.2.doc" to be executed and fetch the table data. I tried anyhow, but it is saying as "No tables".

See my code as below.

Sub importTableDataWord()
    Dim WdApp As Object, wddoc As Object
    Dim strDocName As String

    On Error Resume Next
    Set WdApp = GetObject(, "Word Application")

    If Err.Number = 429 Then
       Err.Clear
        Set WdApp = CreateObject("Word Application")
    End If

    WdApp.Visible = True
    strDocName = "C:\Test\FirstDocV1.2.doc"

'I am manually giving for version 1.2 doc. But I need to select which contains v1.2 version automatically from Test folder.    
    If Dir(strDocName) = "" Then
        MsgBox "The file is not present" & strDocName & vbCrLf & " or was not found"
        Exit Sub
    End If

    WdApp.Activate
    Set wddoc = WdApp.Documents(strDocName)

    If wddoc Is Nothing Then Set wddoc = WdApp.Documents.Open(strDocName)
        wddoc.Activate
        Dim Tble As Integer
        Dim rowWd As Long
        Dim colWd As Long
        Dim x As Long, y As Long

        x = 1
        y = 1

        With wddoc
            Tble = wddoc.tables.Count
            If Tble = 0 Then
                MsgBox "No Tables Found in the document"
                Exit Sub
            End If

            For i = 1 To Tble
                With .tables(i)
                    For rowWd = 1 To .Rows.Count
                        For colWd = 1 To .Columns.Count
                            Cells(x, y) = WorksheetFunction.Clean(.cell(rowWd, colWd).Range.Text)
                            y = y + 1
                        Next colWd
                        y = 1
                        x = x + 1
                    Next rowWd
                End With
            Next
        End With

    wddoc.Close savechanges:=False
    WdApp.Quit

    Set wddoc = Nothing
    Set WdApp = Nothing
End Sub

Can anyone help me please.

Answer 1

There are a number of problems with the code you are not seeing because the error handling isn't working very well for you. I have corrected them below. The On Error Resume Next is not very revealing because when an error occurs, the code just keeps running forward. You want to correct those as you go by catching most of them while you are writing the routine.

Before I made edits, I did a few things which you should get in a habit of doing:

1. Added Option Explict (this will make it harder to introduce bugs in your code because it requires explicit syntax. This is a great discipline and I can't encourage it enough)
2. Compiled . (Do this regularly as you write your code. It will help you solve issues along the way)
3. Declared the variable i . This was flagged when I compiled with Option Explicit (wasn't creating an issue in your code, but bugs are easy to introduce if you don't use explicit variables)

Then I changed to to use specific object references

1. Set a reference to the Word library (this makes debugging way easier because you will have intellisense in the editor and can explore the Word library using [F2])
2. Updated generic object references to Word.Application and Word.Document

Then I fixed the Errors.

First I changed Error Handling to use On Error GoTo, and then I worked through each error that happened as I worked through the code.

1. wdApp.Activate caused an Error
2. wdDoc never actually gets created, so it is Nothing

After I corrected these, I added a line to get the document with "V1.2.doc" in the name.

Finally, I removed the loop so only the first Table was copied as the question requested.

Option Explicit

Public Sub ImportTableDataWord()
    Const FOLDER_PATH As String = "C:\Test\"

    Dim sFile As String

    'use the * wildcard to select the first file ending with "V1.2.doc" 
    sFile = Dir(FOLDER_PATH & "*V1.2.doc")

    If sFile = "" Then
        MsgBox "The file is not present or was not found"
        Exit Sub
    End If

    ImportTableDataWordDoc FOLDER_PATH & sFile

End Sub

Public Sub ImportTableDataWordDoc(ByVal strDocName As String)

    Dim WdApp As Word.Application
    Dim wddoc As Word.Document
    Dim nCount As Integer
    Dim rowWd As Long
    Dim colWd As Long
    Dim x As Long
    Dim y As Long
    Dim i As Long

    On Error GoTo EH

    If strDocName = "" Then
        MsgBox "The file is not present or was not found"
        GoTo FINISH
    End If

    Set WdApp = New Word.Application
    WdApp.Visible = False

    Set wddoc = WdApp.Documents.Open(strDocName)

    If wddoc Is Nothing Then
        MsgBox "No document object"
        GoTo FINISH
    End If

    x = 1
    y = 1

    With wddoc

        If .Tables.Count = 0 Then
            MsgBox "No Tables Found in the document"
            GoTo FINISH
        Else

            With .Tables(1)
                For rowWd = 1 To .Rows.Count
                    For colWd = 1 To .Columns.Count
                        Cells(x, y) = WorksheetFunction.Clean(.Cell(rowWd, colWd).Range.Text)
                        y = y + 1
                    Next 'colWd
                    y = 1
                    x = x + 1
                Next 'rowWd
            End With

        End If

    End With

    GoTo FINISH

EH:

    With Err
        MsgBox "Number" & vbTab & .Number & vbCrLf _
            & "Source" & vbTab & .Source & vbCrLf _
            & .Description
    End With

    'for debugging purposes
    Debug.Assert 0
    GoTo FINISH
    Resume

FINISH:

    On Error Resume Next
    'release resources

    If Not wddoc Is Nothing Then
        wddoc.Close savechanges:=False
        Set wddoc = Nothing
    End If

    If Not WdApp Is Nothing Then
        WdApp.Quit savechanges:=False
        Set WdApp = Nothing
    End If

End Sub