Export Word Table to Excell

[boneKrusher]

Hi all,

Does anyone have a VBA code that exports a word table (from word.activedocument) to excel?

Thanks,

Bones

[geekgirlau]

Sub ExportTableToXL()
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~
' Purpose: Copy the current table to Excel
' Restrictions: Requires a reference to the Microsoft Excel Object Library
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~
Dim objXL As Excel.Application
Dim blnNewWB As Boolean


' is cursor within a table?
On Error GoTo ErrHandler
If Selection.Information(wdWithInTable) = False Then
MsgBox "Please move your cursor to a table before running the macro.", _
vbInformation, "No Table Selected"

Else
Selection.SelectRow
Selection.SelectColumn
Selection.Copy

On Error Resume Next
Set objXL = GetObject(, "Excel.Application")

If Err.Number <> 0 Then
Set objXL = CreateObject("Excel.Application")
blnNewWB = True
End If

On Error GoTo ErrHandler

With objXL
If blnNewWB = False Then
.Workbooks.Add
End If

.Visible = True
.ActiveSheet.Paste
.Application.CutCopyMode = False
End With
End If


ExitHere:
On Error Resume Next
Set objXL = Nothing
Exit Sub

ErrHandler:
MsgBox Err.Description, vbCritical, "Unexpected Error (" & Err.Number & ")"
Resume ExitHere
End Sub

[boneKrusher]

Thanks!

I had to add two lines to open the excel app, I was getting an error. Works great.


Sub ExportTableToXL()
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~
' Purpose: Copy the current table to Excel
' Restrictions: Requires a reference to the Microsoft Excel Object Library
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~
Dim objXL As Excel.Application
Dim blnNewWB As Boolean
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
' is cursor within a table?
On Error GoTo ErrHandler
If Selection.Information(wdWithInTable) = False Then
MsgBox "Please move your cursor to a table before running the macro.", _
vbInformation, "No Table Selected"

Else
Selection.SelectRow
Selection.SelectColumn
Selection.Copy

On Error Resume Next
Set objXL = GetObject(, "Excel.Application")

If Err.Number <> 0 Then
Set objXL = CreateObject("Excel.Application")
blnNewWB = True
End If

On Error GoTo ErrHandler

With objXL
If blnNewWB = False Then
.Workbooks.Add
End If

.Visible = True
.ActiveSheet.Paste
.Application.CutCopyMode = False
End With
End If
Set xlApp = Nothing
Set objXL = Nothing

ExitHere:
On Error Resume Next
Set objXL = Nothing
Exit Sub

ErrHandler:
MsgBox Err.Description, vbCritical, "Unexpected Error (" & Err.Number & ")"
Resume ExitHere
End Sub