Results 1 to 10 of 15

Thread: Help with VBA to extract data from Word to Excel

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1

    Help with VBA to extract data from Word to Excel

    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
    Attached Files Attached Files
    Last edited by AliGW; 2018-04-03 at 09:27 AM. Reason: Code tags added.

  2. #2
    Conjurer snb's Avatar
    Join Date
    May 2013
    Posts
    376
    Articles
    0
    Excel Version
    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

  3. #3
    Quote Originally Posted by snb View Post
    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?

  4. #4
    Acolyte macropod's Avatar
    Join Date
    Mar 2017
    Posts
    42
    Articles
    0
    Excel Version
    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
    Cheers,
    Paul Edstein
    [MS MVP - Word]

  5. #5
    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?

  6. #6
    Acolyte macropod's Avatar
    Join Date
    Mar 2017
    Posts
    42
    Articles
    0
    Excel Version
    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
    Cheers,
    Paul Edstein
    [MS MVP - Word]

  7. #7
    Neophyte lolla1970's Avatar
    Join Date
    Jul 2019
    Posts
    4
    Articles
    0
    Excel Version
    16
    When I run the macro the pop window only let me choose the folder path and not the files

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •