Help with VBA to extract data from Word to Excel

bandituk

New member
Joined
Mar 29, 2018
Messages
4
Reaction score
0
Points
0
Hi All

I need some help modifying code that I found here 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!

Code:
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
 

Attachments

  • PDR Data Master.xlsm
    15.9 KB · Views: 418
Last edited by a moderator:

snb

New member
Joined
May 15, 2013
Messages
376
Reaction score
0
Points
0
Website
www.snb-vba.eu
Excel Version(s)
2020
Code:
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

New member
Joined
Mar 29, 2018
Messages
4
Reaction score
0
Points
0
Code:
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

New member
Joined
Mar 19, 2017
Messages
61
Reaction score
0
Points
0
Excel Version(s)
2010
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.
Code:
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

New member
Joined
Mar 29, 2018
Messages
4
Reaction score
0
Points
0
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

New member
Joined
Mar 19, 2017
Messages
61
Reaction score
0
Points
0
Excel Version(s)
2010
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:
Code:
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

New member
Joined
Mar 29, 2018
Messages
4
Reaction score
0
Points
0
Many thanks for your help Paul - I think I'm sorted now!
 

lolla1970

New member
Joined
Jul 23, 2019
Messages
4
Reaction score
0
Points
0
Excel Version(s)
16
This is to get data from folder how to alter to get data from files I choose? Thanks
 

macropod

New member
Joined
Mar 19, 2017
Messages
61
Reaction score
0
Points
0
Excel Version(s)
2010
Both versions of the code I posted already allows you to do that...
 

lolla1970

New member
Joined
Jul 23, 2019
Messages
4
Reaction score
0
Points
0
Excel Version(s)
16
It is not letting me choose the word file.
 

lolla1970

New member
Joined
Jul 23, 2019
Messages
4
Reaction score
0
Points
0
Excel Version(s)
16
When I run the macro the pop window only let me choose the folder path and not the files
 

lolla1970

New member
Joined
Jul 23, 2019
Messages
4
Reaction score
0
Points
0
Excel Version(s)
16
It work sorry I was missing it. It works now. Thank you
 

macropod

New member
Joined
Mar 19, 2017
Messages
61
Reaction score
0
Points
0
Excel Version(s)
2010
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

New member
Joined
Jul 31, 2019
Messages
2
Reaction score
0
Points
0
Excel Version(s)
19
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?
 

Greyness

New member
Joined
Jul 31, 2019
Messages
2
Reaction score
0
Points
0
Excel Version(s)
19
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:

It would have been helpful had you stated up-front which tables you want the data from. Try:
Code:
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

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

New member
Joined
Mar 19, 2017
Messages
61
Reaction score
0
Points
0
Excel Version(s)
2010
The code I posted, which doesn't use "With .Tables(t)", works just fine...
 
Top