Performance tuning of Excel VBA which Import Word Tables

[venkatmandada]

Hi,

I have macro which imports word tables into Excel with the following code

Sub ImportWordTable()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim ParaNo As Integer
Dim iRow As Long 'row index in Excel
Dim iCol As Integer, icol1 As Integer 'column index in Excel
'Dim sHeader As String
Dim sHeader(50) As String
Dim Head1counter As Integer
Dim arrcount As Long
Dim mHeading As String




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 wdDoc = GetObject(wdFileName) 'open Word file
'Remove numbering
With wdDoc
wdDoc.ConvertNumbersToText
End With
'end remove numbering


Worksheets.Application.Sheets("Tests").Activate
With wdDoc
TableNo = wdDoc.tables.Count
If TableNo = 0 Then
MsgBox "This document contains no tables", _
vbExclamation, "Import Word Table"
ElseIf TableNo > 1 Then
End If

'Table insertion shoud start from 8th cell (if empty) else from the next available empty cell 
If Worksheets("Tests").Cells(8, 1).Value = "" Then
celli = 8
Else
'celli = Cells(1, 9).Value
celli = Cells(Rows.Count, 1).End(xlUp).Row + 1
End If

'Take all 'Heading 1' style text in array
  p = 1
  RetCount = 0
  parg = wdDoc.Paragraphs.Count
  
For Head1counter = 1 To parg
  
   If wdDoc.Paragraphs(Head1counter).Style = "Heading 1" Then
         sHeader(p) = wdDoc.Paragraphs(Head1counter).Range.Text
        p = p + 1
   Else
        p = p
   End If
Next Head1counter
 
  

'Iterate all tables
For i = 3 To TableNo


With .tables(i)
'copy cell contents from Word table cells to Excel cells  .Paragraphs.Count


 rowc = .Rows.Count
 iCol = .Columns.Count
 
 If iCol > 1 Then
 
'Send each Heading 1 text for each table being imported.
For arrcount = RetCount + 1 To UBound(sHeader)
  If sHeader(arrcount) <> "" Then
        mHeading = sHeader(arrcount)
        RetCount = arrcount
Exit For
  Else
        RetCount = RetCount
  End If
Next arrcount
  


For iRow = 2 To rowc
  For iCol = 1 To 3
        
        Cells(celli, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
        Cells(celli, 4) = mHeading
    
  Next iCol
    celli = celli + 1
Next iRow
    
 End If


End With


'v1 = v1 + 1
Next i


End With
'added to check
Cells(1, 9) = celli
'end here
Set wdDoc = Nothing


End Sub

It is working fine but taking huge time to populate word data into excel.

Briefly what it does is, takes the word document and fetch every table with greater than one column and paste in the excel.
Also it will fetch the 'Heading 1' text, header of each table and populate in one column.

Currently it is taking huge time identifying the 'Heading 1' text into array.

I am very thankful to have any expert suggestions to optimize the performance of the macro.

Many Thanks
Venky

 

[VoG]

This should be faster but it doesn't grab the headings

Sub ImportWordTable3()
'Import all tables to a single sheet
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Word
Dim jRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
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
    If wdDoc.tables.Count = 0 Then
        MsgBox "This document contains no tables", _
            vbExclamation, "Import Word Table"
    Else
        jRow = 0
        Sheets.Add after:=Sheets(Worksheets.Count)
        For TableNo = 1 To wdDoc.tables.Count
            With .tables(TableNo)
'copy cell contents from Word table cells to Excel cells
                For iRow = 1 To .Rows.Count
                    jRow = jRow + 1
                    For iCol = 1 To .Columns.Count
                        On Error Resume Next
                        ActiveSheet.Cells(jRow, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
                        On Error GoTo 0
                    Next iCol
                Next iRow
            End With
            jRow = jRow + 1
        Next TableNo
    End If
End With
Set wdDoc = Nothing
End Sub