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

[macropod]

Other than:
SaveChanges:=False
which should just be:
False,
there is nothing about your code that could cause an error when used on different Office versions. What error(s) are you getting?

[Dave]

You need to be specific about your sheet reference...

Sheets("Sheet1").Cells(1, 1)
HTH. Dave
edit: You may also want to trial this instead of all that other stuff

Sheets("sheet1").Cells(r, c).Value = Application.WorksheetFunction.Clean(oCell.Range.Text)

[Kijoon]

Hi guys thanks for the comments. Sorry for the late reply as I had to try it out on both machines.



What error(s) are you getting?


the result is that the values are simply shown as a single continuous string, instead of including the paragraph breaks as intended. There was no error message shown.







Sheets("sheet1").Cells(r, c).Value = Application.WorksheetFunction.Clean(oCell.Range.Text)


I tried this but it did not have any impact. It could be used as an alternative to erasing the 'bullet points' (Chr(7)) but even it did not have any impact on bringing the paragraph breaks to the excel 2013 spreadsheet.

[macropod]

See: Help with VBA to extract data from Word to Excel (excelguru.ca) (https://www.excelguru.ca/forums/showthread.php?8900-Help-with-VBA-to-extract-data-from-Word-to-Excel)