Transforming Word tables into Excel array - vba

Question

I am trying to transfer Word tables to Excel - this has already been done here - and in addition, during the transfer I'd like to keep only rows that contain certain content, and would like to reshape the table before pasting it into Excel. I thought this could be done by converting each table first into an Excel array and then modifying the array as needed before pasting it to a specified range. Yet, I am not so familiar with Word VBA and I am finding this task pretty hard. I am starting from this code here, which I found at the post referenced above.
Option Explicit
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 (*.docx),*.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
tableTot = wdDoc.tables.Count
If tableTot = 0 Then
MsgBox "This document contains no tables", _
vbExclamation, "Import Word Table"
End If
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
I think I should change this chunk to obtain what I am looking for.
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
Can someone help me with this? I can provide more details if needed. Many thanks!
Riccardo

Answer 1

If you want to copy only certain rows:
For tableStart = 1 To tableTot
With .tables(tableStart)
For iRow = 1 To .Rows.Count
v = WorksheetFunction.Clean(.cell(iRow, 1).Range.Text)
If v = "A" Or v = "B" Or v = "C" Then
For iCol = 1 To .Columns.Count
Cells(resultRow, iCol) = WorksheetFunction.Clean( _
.cell(iRow, iCol).Range.Text)
Next iCol
resultRow = resultRow + 1
End If
Next iRow
End With
resultRow = resultRow + 1
Next tableStart

Answer 2

With the help of Tim, this is the code that does what I was looking for.
Sub ImportWordTable()
Dim wdDoc As Object
Dim wdFileName, v, cont 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
Dim rtemp, i As Integer
Dim categ(4), content(4) As Variant
Dim found, temprange As Range
Worksheets.Add.Name = "tempsht"
Worksheets.Add.Name = "final"
With Sheets("final")
.Cells(1, 1) = "Author"
.Cells(1, 2) = "Title"
.Cells(1, 3) = "Date"
.Cells(1, 4) = "Publication name"
.Cells(1, 5) = "Word count"
End With
categ(0) = "BY"
categ(1) = "HD"
categ(2) = "PD"
categ(3) = "SN"
categ(4) = "WC"
resultRow = 2
wdFileName = Application.GetOpenFilename("Word files (*.rtf),*.rtf", , "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
tableTot = wdDoc.tables.Count
If tableTot = 0 Then
MsgBox "This document contains no tables", _
vbExclamation, "Import Word Table"
End If
For tableStart = 1 To tableTot - 1
With .tables(tableStart) 'subset the table and copy it to a tempsheet
rtemp = 1
For iRow = 1 To .Rows.Count
v = WorksheetFunction.Clean(.cell(iRow, 1).Range.Text)
If v = " HD" Or v = " BY" Or v = " WC" Or v = " PD" Or v = " SN" Or v = "HD" Or v = "BY" Or v = "WC" Or v = "PD" Or v = "SN" Then
For iCol = 1 To .Columns.Count
Sheets("tempsht").Cells(rtemp, iCol) = Trim(WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text))
Next iCol
rtemp = rtemp + 1
End If
Next iRow
Set temprange = Sheets("tempsht").Range("A1:A5")
With temprange
For i = 0 To 4
Set found = .find(What:=categ(i))
If found Is Nothing Then
content(i) = ""
Else
content(i) = Sheets("tempsht").Cells(found.Row, 2).Value
End If
Next i
End With
Sheets("final").Range(Cells(resultRow, 1), Cells(resultRow, 5)) = content
Sheets("tempsht").Range("A1:B5").ClearContents 'remove content from tempsheet
End With
resultRow = resultRow + 1
Next tableStart
Application.DisplayAlerts = False 'delete temporary sheet
Sheets("tempsht").Select
ActiveWindow.SelectedSheets.Delete
End With
End Sub