CODEWITHSUNDEEP
vbaexcelms-word
user7415328
user7415328

Reputation: 1083

Retrieve text from table in Microsoft Word?

I have a word document like so:

Table 1

Table 2
Some Text
My Value

I am trying to use VBA in excel to retrieve the text from table 2 and put it into my sheet ("Calculations").

For some reason this does not work and no values are appearing on my sheet. I get no error.

Here is my code:

Sub ImportWordTable()
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
'Application.EnableEvents = False

Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel

wdFileName = Worksheets("Calculations").Range("A1").Value & "\" & AlphaNumericOnly(Worksheets("Supplier").Range("O" & ActiveCell.Row).Value) & "_CAP_" & Replace(Worksheets("Supplier").Range("T" & ActiveCell.Row).Value, "/", ".") & ".doc"

If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
MsgBox wdDoc



With wdDoc
    TableNo = wdDoc.Tables.Count
    If TableNo = 0 Then

    ElseIf TableNo > 1 Then
        TableNo = "2"
    End If
    With .Tables(TableNo)
        'copy cell contents from Word table cells to Excel cells
        For iRow = 1 To Worksheets("Calculations").Rows.Count
            For iCol = 1 To Worksheets("Calculations").Columns.Count
                Cells(iRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
            Next iCol
        Next iRow
End With
End With


Set wdDoc = Nothing

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

End Sub


Function AlphaNumericOnly(strSource As String) As String
    Dim i As Integer
    Dim strResult As String

    For i = 1 To Len(strSource)
        Select Case Asc(Mid(strSource, i, 1))
            Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space
                strResult = strResult & Mid(strSource, i, 1)
        End Select
    Next
    AlphaNumericOnly = strResult
End Function

Please can someone show me where i am going wrong?

Upvotes: 0

Views: 4314

Answers (1)

Siddharth Rout
Siddharth Rout

Reputation: 149287

Why are you looping through the Worksheet's rows and columns?

With .Tables(TableNo)
    'copy cell contents from Word table cells to Excel cells
    For iRow = 1 To Worksheets("Calculations").Rows.Count
        For iCol = 1 To Worksheets("Calculations").Columns.Count
            Cells(iRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
        Next iCol
    Next iRow
End With

You need to loop through the table rows and columns. Try this (Untested)

Dim excelRow As Long, excelCol As Long

excelRow = 1

With .Tables(TableNo)
    'copy cell contents from Word table cells to Excel cells
    For iRow = 1 To .Rows.Count
        excelCol = 1
        For iCol = 1 To .Columns.Count
            Worksheets("Calculations").Cells(excelRow, excelCol) = _
            WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
            excelCol = excelCol + 1
        Next iCol
        excelRow = excelRow + 1
    Next iRow
End With

EDIT

I tested this and it works

enter image description here

Code

Sub ImportWordTable()
    Dim oWordApp As Object, wdDoc As Object
    Dim iRow As Long, iCol As Long
    Dim excelRow As Long, excelCol As Long
    Dim Filename As String

    Filename = "C:\Users\Siddharth\Desktop\DeleteMeLater.docx"

    Set oWordApp = CreateObject("Word.Application")
    oWordApp.Visible = True
    Set wdDoc = oWordApp.Documents.Open(Filename)

    With wdDoc
        If wdDoc.Tables.Count > 1 Then
            With .Tables(2)
                excelRow = 1
                'copy cell contents from Word table cells to Excel cells
                For iRow = 1 To .Rows.Count
                    excelCol = 1
                    For iCol = 1 To .Columns.Count
                        Worksheets("Calculations").Cells(excelRow, excelCol) = _
                        WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
                        excelCol = excelCol + 1
                    Next iCol
                    excelRow = excelRow + 1
                Next iRow
            End With
        End If
    End With

    Set wdDoc = Nothing
End Sub

Upvotes: 1

Related Questions