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!!