Cross posted
http://www.eileenslounge.com/viewtopic.php?f=26&t=37822
hi all.
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
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 original link
https://answers.microsoft.com/en-us/...d-c9a981636d24
anyone help me out..greatly appreciated
.susanto
Bookmarks