PDA

View Full Version : Help with VBA to extract data from Word to Excel



bandituk
2018-03-29, 05:09 PM
Hi All

I need some help modifying code that I found here (https://stackoverflow.com/questions/4465212/macro-to-export-ms-word-tables-to-excel-sheets) and is shown below, which copies entries from tables in Word into Excel. The modifications I would like to make are to loop through all word documents in the current folder rather than prompting for a file name, with the data from each Word document appearing as a new Sheet.

The alternative is to have each Word document represented by a row in a sheet, with all data from the tables in that document in separate columns.

Thanks in advance!


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
Dim i As Long
Dim r As Long
Dim c As Long
Dim lastrow As Long


On Error Resume Next


wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file containing table to be imported")


If wdFileName = False Then Exit Sub '(user cancelled import file browser)


ActiveSheet.Range("A:AZ").ClearContents


Set wdDoc = GetObject(wdFileName) 'open Word file






With wdDoc
tableNo = wdDoc.tables.Count
For i = 1 To tableNo
With .tables(i)
'copy cell contents from Word table cells to Excel cells
For iRow = lastrow To .Rows.Count
For iCol = 1 To .Columns.Count
On Error Resume Next
Worksheets("Data").Cells(r, c) = Trim(WorksheetFunction.Clean(Replace(Replace(.cell(iRow, iCol).Range.Text, Chr(13), " "), Chr(10), "")))
c = c + 1
Next iCol
c = 1
r = r + 1
Next iRow
End With
c = 1
Next i


End With
End Sub

snb
2018-03-29, 05:23 PM
Sub M_snb()
sn=split(createobject("wscript.shell").exec("cmd /c Dir ""G:\OF\*.doc*"" /b/s ").stdout.readall,vbcrlf)

for j=0 to ubound(sn)-1
with getobject(sn(j))
for each it in .tables
it.range.copy
sheets.add( ,sheets(sheets.count)).Paste cells(1)
next
.close 0
end with
next
End Sub

bandituk
2018-03-29, 05:50 PM
Sub M_snb()
sn=split(createobject("wscript.shell").exec("cmd /c Dir ""G:\OF\*.doc*"" /b/s ").stdout.readall,vbcrlf)

for j=0 to ubound(sn)-1
with getobject(sn(j))
for each it in .tables
it.range.copy
sheets.add( ,sheets(sheets.count)).Paste cells(1)
next
.close 0
end with
next
End Sub

Thanks for the response but unfortunately that gives me an error..... whereabouts should I be inserting it?

macropod
2018-03-30, 05:07 AM
Try the following. The macro allows you to choose the source folder. It creates a new worksheet for each document and outputs all tables from that document one below the other, with an empty row in between. Except for text wrapping, table formatting is preserved as much as possible.

Sub GetTableData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document, wdTbl As Word.Table
Dim strFolder As String, strFile As String, WkBk As Workbook, WkSht As Worksheet, r As Long
strFolder = GetFolder: If strFolder = "" Then GoTo ErrExit
Set WkBk = ActiveWorkbook
'Disable any auto macros in the documents being processed
wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
Set WkSht = WkBk.Sheets.Add
WkSht.Name = Split(strFile, ".doc")(0)
With wdDoc
For Each wdTbl In .Tables
With wdTbl.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[^13^l]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
If r > 1 Then r = r + 2
wdTbl.Range.Copy
WkSht.Paste Destination:=WkSht.Range("A" & r)
Next
WkSht.UsedRange.Replace What:="", Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
ErrExit:
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing: Set WkBk = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

bandituk
2018-03-30, 11:42 AM
That's almost perfect Paul - many thanks! It's actually copying more than I intended including some images - can I restrict it to table 1 and table 6?

macropod
2018-03-31, 04:51 AM
The code I posted only copies tables. If you're getting images, that's because they're in/attached to the tables. And you did say you wanted:


all data from the tables in that document
It would have been helpful had you stated up-front which tables you want the data from. Try:

Sub GetTableData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document, t As Long
Dim strFolder As String, strFile As String, WkBk As Workbook, WkSht As Worksheet, r As Long
strFolder = GetFolder: If strFolder = "" Then GoTo ErrExit
Set WkBk = ActiveWorkbook
'Disable any auto macros in the documents being processed
wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
Set WkSht = WkBk.Sheets.Add
WkSht.Name = Split(strFile, ".doc")(0)
With wdDoc
For t = 1 To .Tables.Count
Select Case t
Case 1, 6
With .Tables(t)
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[^13^l]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
If r > 1 Then r = r + 2
wdTbl.Range.Copy
WkSht.Paste Destination:=WkSht.Range("A" & r)
Case Is > 6: Exit For
End Select
Next
WkSht.UsedRange.Replace What:="", Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
ErrExit:
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing: Set WkBk = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

bandituk
2018-04-03, 09:22 AM
Many thanks for your help Paul - I think I'm sorted now!

lolla1970
2019-07-23, 02:52 PM
This is to get data from folder how to alter to get data from files I choose? Thanks

macropod
2019-07-23, 03:45 PM
Both versions of the code I posted already allows you to do that...

lolla1970
2019-07-23, 04:21 PM
It is not letting me choose the word file.

lolla1970
2019-07-23, 04:23 PM
When I run the macro the pop window only let me choose the folder path and not the files

lolla1970
2019-07-23, 05:34 PM
It work sorry I was missing it. It works now. Thank you

macropod
2019-07-23, 11:32 PM
The code is for choosing the folder. All documents in that folder are processed. If you want to process only a limited number of documents, then make sure they're the only documents in the folder.

Greyness
2019-07-31, 05:55 PM
I am trying to do "Word to Excel" with all datas and images. When I try to use this code, I got a error message "Method or data member not found" on "Sub GetTableData()". Then I figured it out that "With .Tables(t)" causes this error. How can I solve it, can you help me?

macropod
2019-08-01, 01:15 AM
The code I posted, which doesn't use "With .Tables(t)", works just fine...