Extract Copy All Tables from Word into Excel

[ChrisOK]

I've got some code that successfully extracts all the tables from within a Word doc - over into Excel - however, I'm wondering if anyone knows of a way to make it highlight/color/or draw a bold dark line between each table as it is pasting them downward in sequence.
(need to be able to easily scroll down and see where a new table starts - so drawing that line - or turning that top row a color would be awesome if doable?)

Here's what I'm using now / but totally open to something different/better:

Sub ImportWordTable()

 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
 Dim resultRow As Long
 Dim tableStart As Integer
 Dim tableTot As Integer

 On Error Resume Next

 ActiveSheet.Range("A:AZ").ClearContents

 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)

 Set wdDoc = GetObject(wdFileName) 'open Word file

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

 resultRow = 4

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

 End Sub

 

[Macropod]

Try:

Sub ImportWordTable()

Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Long 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Long 'column index in Excel
Dim resultRow As Long
Dim tableStart As Long
Dim tableTot As Long
Dim wkSht As Worksheet

On Error Resume Next

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)
  Set wkSht = ActiveSheet
  wkSht.Range("A:AZ").ClearContents

  Set wdDoc = GetObject(wdFileName) 'open Word file

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

    resultRow = 4

    For tableStart = 1 To tableTot
      With .Tables(tableStart)
        'copy cell contents from Word table cells to Excel cells
        For iRow = 1 To .Rows.Count
          For iCol = 1 To .Columns.Count
            wkSht.Cells(resultRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
          Next iCol
          resultRow = resultRow + 1
        Next iRow
      End With
      resultRow = resultRow + 1
      With wkSht
        .Range(.Cells(resultRow, 1), .Cells(resultRow, iCol)).Interior.ColorIndex = 15
      End With
      resultRow = resultRow + 1
    Next tableStart
End With

End Sub

 

[ChrisOK]

PERFECT! Separator bar is in place!
Thanks Paul!

 

[srini0712]

@Macropod @ChrisOK

Do you have code to extract specific tables from word to excel. user should be able to select the tables they want to extract from word to excel. any help on this please.