extracting from multiple word tables to excel sheet

[Kijoon]

Hi all,

I have a code that extracts table cell values from multiple word docs into a single excel sheet.

I have adjusted the code so it identifies the paragraph break (and line break) from word table cells and implement them into the excel cells. However, this works fine on my office 365 version I have at home but not the excel 2013 version I have at work.

I want to adjust the code so it would be compatible for the office 2013 version for others to use (and I can't ask my office to purchase 365 just for this).

My understanding is that the vba versions of 365 and 2013 are the same, so I don't understand why this doesn't work.

any inputs?


my code:

Sub ImportWordTable()



Dim oWord As Object
Dim oDoc As Object
Dim oTable As Object
Dim oCell As Object
Dim sPath As String
Dim sFile As String
Dim r As Long
Dim c As Long
Dim Cnt As Long




Application.ScreenUpdating = False
On Error Resume Next 'tells VBA to ignore errors
Set oWord = GetObject(, "Word.Application")
If Err Then
  Set oWord = CreateObject("Word.Application")
End If
On Error GoTo 0
sPath = "C:\folder" 'change the path accordingly
If Right(sPath, 1) <> "" Then sPath = sPath & ""
sFile = Dir(sPath & "*.doc")


Cells.Clear


Cells(1, 1).Value = "File Name"
Cells(1, 1).Font.Bold = True
Cells(1, 1).Font.Color = vbBlue
Cells(1, 2).Value = "Contents -->"
Cells(1, 2).Font.Bold = True
Cells(1, 2).Font.Color = vbBlue


r = 2 'starting row
c = 2 'starting column
Cnt = 0
Do While Len(sFile) > 0


  Cnt = Cnt + 1
  Set oDoc = oWord.Documents.Open(sPath & sFile)
  If oDoc.Tables.Count > 0 Then
    Cells(r, c - 1).Value = sFile
    For Each oTable In oDoc.Tables
      For Each oCell In oTable.Range.Cells


        Cells(r, c).Value = Replace(oCell.Range.Text, Chr(13) & Chr(7), "")
        Cells(r, c).Value = Replace(oCell.Range.Text, "^p", vbCrLf) 'changes the paragraph break into vba code
        Cells(r, c).Value = Replace(oCell.Range.Text, "^l", vbCrLf) 'changes the line break into vba code
        Cells(r, c).Value = Replace(oCell.Range.Text, Chr(7), "") ' erases the 'button' that shows in the cell
        Cells(r, c).Value = Left(Cells(r, c).Value, Len(Cells(r, c).Value) - 1) 'erases that one paragraph break that shows in the end of each cell
        c = c + 1
      Next oCell
    Next oTable
    r = r + 1
    c = 2
  End If
  oDoc.Close SaveChanges:=False
  sFile = Dir
  DoEvents
Loop
Application.ScreenUpdating = True
If Cnt = 0 Then
  MsgBox "No Word documents were found...", vbExclamation
End If
End Sub

thanks!!