Copy data from Word to Excel using VBA

[xPukwe]

Hi everybody,
---

I want to copy data from a Word document containing tables. These tables could contain paragraphs of words or images.

I used the code below found in a video of youtuber "Dinesh Kumar Takyar",

This code dosen't copy images and i have a problem with the formatting of the row height and column width as it just copies it in one continuing line of text,

I want to be able to copy images and to format the row height and column width,

Sub importTableDataWord()
    'We declare object variables for Word Application and document
    Dim WdApp As Object, wddoc As Object
    'Declare a string variable to access our Word document
    Dim strDocName As String
    'Error handling
    On Error Resume Next
    'Activate Word it is already open
    Set WdApp = GetObject(, "Word.Application")
    If Err.Number = 429 Then
        Err.Clear
        'Create a Word application if Word is not already open
        Set WdApp = CreateObject("Word.Application")
    End If
    WdApp.Visible = True
    
    strDocName = "C:\Users\mtouahri\Desktop\TestWord.docx" ' ### change the name of the document
    'Check relevant directory for relevant document
    'If not found then inform the user and close program
    If Dir(strDocName) = "" Then
        MsgBox "The file " & strDocName & vbCrLf & "was not found in the folder path" & vbCrLf & _
        "C:\Users\mtouahri\.", vbExclamation, "Sorry, that document name does not exist." '###
        Exit Sub
    End If
    
    WdApp.Activate
    
    Set wddoc = WdApp.Documents(strDocName)
    
    If wddoc Is Nothing Then Set wddoc = WdApp.Documents.Open(strDocName)
    wddoc.Activate
    'define variables to access the tables in the word document
    Dim Tble As Integer
    Dim rowWd As Long
    Dim colWd As Integer
    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 Word document", vbExclamation, "No Tables to Import"
            Exit Sub
        End If
        'start the looping process to access tables and their rows, columns
        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)
                        'Access next column
                        y = y + 1
                    Next colWd
                'go to next row and start from column 1
                y = 1
                x = x + 1
        
                Next rowWd
             End With
        
        Next
    End With
    'we don’t need to save the word document
    wddoc.Close Savechanges:=False
    'we quit Word
    WdApp.Quit
    'We finally release system memory allocated to the 2 object variables
    Set wddoc = Nothing
    Set WdApp = Nothing
End Sub

xPukwe,