i found code from google but i don't how the code is worked well, i have testing but not work
i want the code can copy table from ms word into ms excel
here code :
Sub CopyTables()
Dim oWord As Word.Application
Dim WordNotOpen As Boolean
Dim oDoc As Word.Document
Dim oTbl As Word.Table
Dim fd As Office.FileDialog
Dim FilePath As String
Dim wbk As Workbook
Dim wsh As Worksheet
' Prompt for document
Set fd = Application.FileDialog(msoFileDialogOpen)
With fd
.Filters.Clear
.Filters.Add "Word Documents (*.docx)", "*.docx", 1
.Title = "Choose a Word File"
If .Show = True Then
FilePath = .SelectedItems(1)
Else
Beep
Exit Sub
End If
End With
On Error Resume Next
Application.ScreenUpdating = False
' Create new workbook
Set wbk = Workbooks.Add(Template:=xlWBATWorksheet)
' Get or start Word
Set oWord = GetObject(Class:="Word.Application")
If Err Then
Set oWord = New Word.Application
WordNotOpen = True
End If
On Error GoTo Err_Handler
' Open document
Set oDoc = oWord.Documents.Open(Filename:=FilePath)
' Loop through the tables
For Each oTbl In oDoc.Tables
' Create new sheet
Set wsh = wbk.Worksheets.Add(After:=wbk.Worksheets(wbk.Worksheets.Count))
' Copy/paste the table
oTbl.Range.Copy
wsh.Paste
Next oTbl
' Delete the first sheet
Application.DisplayAlerts = False
wbk.Worksheets(1).Delete
Application.DisplayAlerts = True
Exit_Handler:
On Error Resume Next
oDoc.Close SaveChanges:=False
If WordNotOpen Then
oWord.Quit
End If
'Release object references
Set oTbl = Nothing
Set oDoc = Nothing
Set oWord = Nothing
Application.ScreenUpdating = True
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
Resume Exit_Handler
End Sub
This code should be run from Excel.
Please do the following:
Start Excel.
Press Alt+F11 to activate the Visual Basic Editor.
Select Insert > Module.
Select Tools > References...
Scroll down the list until you see 'Microsoft Word 16.0 Object Library'. If you have an older version of Office, the 16.0 might be 15.0 or 14.0.
Tick the check box of this item in the list.
Click OK.
Copy the code into the module.
You can run the code by clicking anywhere in it and pressing F5, or by switching back to Excel, then pressing Alt+F8, selecting the macro and clicking Run.
hi HansV, thank you so much..
but not fully working..
for first time is work, but after i close that file the macro not work cause Microsoft Word 15 Object Library can't save (can't checked permanent).
if i use new excel file Microsoft Word 15 Object Library not checked again..
i want that macro code to be add-ins excel
how to fix it.
Last edited by Susanto3311 on 17 Feb 2022, 08:45, edited 1 time in total.
If you want the macro to be available permanently, change it as shown below and save it in your personal macro workbook Personal.xlsb.
See Excel Personal Macro Workbook | Save & Use Macros in All Workbooks for info about the personal macro workbook.
You won't have to set a reference to the Microsoft Word 15 Object Library.
Sub CopyTables()
Dim oWord As Object
Dim WordNotOpen As Boolean
Dim oDoc As Object
Dim oTbl As Object
Dim fd As Office.FileDialog
Dim FilePath As String
Dim wbk As Workbook
Dim wsh As Worksheet
' Prompt for document
Set fd = Application.FileDialog(msoFileDialogOpen)
With fd
.Filters.Clear
.Filters.Add "Word Documents (*.docx)", "*.docx", 1
.Title = "Choose a Word File"
If .Show = True Then
FilePath = .SelectedItems(1)
Else
Beep
Exit Sub
End If
End With
On Error Resume Next
Application.ScreenUpdating = False
' Create new workbook
Set wbk = Workbooks.Add(Template:=xlWBATWorksheet)
' Get or start Word
Set oWord = GetObject(Class:="Word.Application")
If Err Then
Set oWord = CreateObject(Class:="Word.Application")
WordNotOpen = True
End If
On Error GoTo Err_Handler
' Open document
Set oDoc = oWord.Documents.Open(Filename:=FilePath)
' Loop through the tables
For Each oTbl In oDoc.Tables
' Create new sheet
Set wsh = wbk.Worksheets.Add(After:=wbk.Worksheets(wbk.Worksheets.Count))
' Copy/paste the table
oTbl.Range.Copy
wsh.Paste
Next oTbl
' Delete the first sheet
Application.DisplayAlerts = False
wbk.Worksheets(1).Delete
Application.DisplayAlerts = True
Exit_Handler:
On Error Resume Next
oDoc.Close SaveChanges:=False
If WordNotOpen Then
oWord.Quit
End If
'Release object references
Set oTbl = Nothing
Set oDoc = Nothing
Set oWord = Nothing
Application.ScreenUpdating = True
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
Resume Exit_Handler
End Sub
