I'm looking to use VBA to copy tables from a word document (there are about
80 pages in the word document, with 1 table per page) and I want to copy
them to a new sheet in a new workbook. I've seen some code on this
site, but I'm unclear how to do the "loop." The word document will be
located in a specific directory and I want to save
the new excel document with the same name as the word document back to that
same directory. Is it better to start with both the word and excel
documents open or is it better to have the VBA open and close them? Please let me
know the best way to proceed. Any and all help would/is appreciated.
Thank you
Copy Word Tables to Excel
-
- Administrator
- Posts: 78558
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Copy Word Tables to Excel
Welcome to Eileen's Lounge!
I'll work on it. Stay tuned.
I'll work on it. Stay tuned.
Best wishes,
Hans
Hans
-
- Administrator
- Posts: 78558
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Copy Word Tables to Excel
The following macro is intended to be run from Word. Make sure that the document with the tables is the active document.
I'm not sure about saving to OneDrive, I have no experience with that, so I hope it'll work.
I'm not sure about saving to OneDrive, I have no experience with that, so I hope it'll work.
Code: Select all
Sub CopyTables()
Dim xlApp As Object
Dim xlWbk As Object
Dim xlWsh As Object
Dim f As Boolean
Dim doc As Document
Dim tbl As Table
Dim sFile As String
On Error Resume Next
' Try to get running instance of Excel
Set xlApp = GetObject(Class:="Excel.Application")
If xlApp Is Nothing Then
' If that failed, start Excel
Set xlApp = CreateObject(Class:="Excel.Application")
f = True
End If
On Error GoTo ErrHandler
' Create a workbook with one sheet
Set xlWbk = xlApp.Workbooks.Add(Template:=-4167) ' xlWBATWorksheet
' Refer to the active document
Set doc = ActiveDocument
' Loop through the tables in the document
For Each tbl In doc.Tables
' Copy the table
tbl.Range.Copy
' Create a new sheet after the existing sheet(s)
Set xlWsh = xlWbk.Worksheets.Add(After:=xlWbk.Worksheets(xlWbk.Worksheets.Count))
' Paste the table
xlWsh.PasteSpecial Format:="HTML", NoHTMLFormatting:=True ' or False
Next tbl
' Delete the (empty) first sheet
xlApp.DisplayAlerts = False
xlWbk.Worksheets(1).Delete
xlApp.DisplayAlerts = True
' Save the new workbook
sFile = doc.FullName
sFile = Left(sFile, InStrRev(sFile, ".")) & "xlsx"
xlWbk.SaveAs FileName:=sFile, FileFormat:=51 ' xlOpenXMLWorkbook
ExitHandler:
On Error Resume Next
' Try to close the workbook
xlWbk.Close SaveChanges:=False
' If we started Excel, close it
If f Then
xlApp.Quit
End If
Exit Sub
ErrHandler:
' Report error message
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
Best wishes,
Hans
Hans