Solved: Copy the table in Word document to NEW Excel file

[Ann_BBO]

Hi All,

The attached Word document has a 3 headings and 2nd heading which is called "2. SYSTEM PARAMETERS" . Under 2nd heading, it has a many tables that i would like to copy to NEW excel workbook. I have already written a excel marco for input the file but don't know how to copy the table in Word File to NEW Excel workbook by using Excel Marco.

Thanks&regards,
Ann

[Ann_BBO]

Anyone know how to do this?? I know it may need to call the object to open and the word document. If you don't understand my question, let me know. Thanks

Ann

[Ann_BBO]

Hi All,

Now, i can open the word document. Here is the code

Sub OpenWordDoc()

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
Set wdDoc = wdApp.Documents.Open("C:\TestDocument.doc")
wdApp.Visible = True

End Sub


However, in the attached file, i don't know how to copy all tables in word document (under 2nd heading) to new excel file.

Thanks,
Ann

[GTO]

Greetings Ann,

I downloaded the Word .doc at post #1, but when I attempted to open it, it kept giving me a path/name error. I created another .doc in the same folder, which opened fine, as well as renamed yours, which still gave the same error.

I think that maybe the file corrupted; could you post another example document?

Mark

[Ann_BBO]

Hi GTO,

Thanks. The attached is the new document. Let me know if you cannot open the document again.

Now, i have tried to write the marco in excel and now it can open the word file document and find out 2nd Heading. The codes is similar to below
Sub OpenWordDoc()
Dim wdRng As Object

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
Set wdDoc = wdApp.Documents.Open("C:\Modified Test Document.doc")
wdApp.Visible = True
Set wdRng = wdApp.Selection
wdRng.Find.Style = wdDoc.Styles("Heading 1")
wdRng.Find.Text = "SYSTEM PARAMETERS"
wdRng.Find.Forward = True
wdRng.Find.Wrap = wdFindAsk
wdRng.Find.Format = True
wdRng.Find.MatchCase = False
wdRng.Find.MatchWholeWord = False
wdRng.Find.MatchByte = False
wdRng.Find.MatchWildcards = False
wdRng.Find.MatchSoundsLike = False
wdRng.Find.MatchAllWordForms = False
wdRng.Find.Execute
End Sub

But the problem is: I don't know how to copy all tables between 2nd heading and 3rd heading into new excel sheet.

Thanks,
Ann

[Tinbendr]

Partial solution here (http://www.vbaexpress.com/forum/showthread.php?t=28801)

[GTO]

Greetings,

I tried for a bit, but wasn't getting anywhere... Thanks to Tinbendr, here's his code incorporated into a basic paste a table per sheet example.

I did note that you appeared to be declaring late-bound (As Object) but had at least one Word Constant in yours. I guessed at late-bound.

Option Explicit

Sub OpenWordDoc()
Dim wdApp As Object ' Word.Application
Dim wdDoc As Object ' Word.Document
Dim oWD_rng As Object ' Word.Range
Dim oWD_Table As Object ' Word.Table

Dim wksNewSheet As Worksheet

Dim lRngStart As Long
Dim lRngEnd As Long

Dim strPath As String
Dim strFilename As String

'// Change path and filename to suit. //
strPath = ThisWorkbook.Path & "\"
strFilename = "Modified Test Document_SaveAs_2.doc"

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number > 0 Then
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0

Set wdDoc = wdApp.Documents.Open(strPath & strFilename)
wdApp.Visible = True
Set oWD_rng = wdDoc.Range

Do
With oWD_rng.Find
.ClearFormatting
.Style = wdDoc.Styles(-2) 'wdStyleHeading1
.Text = "SYSTEM PARAMETERS"
.Forward = True
.Wrap = 0 'wdFindStop
.Execute
End With

If oWD_rng.Find.Found Then
lRngStart = oWD_rng.End

Set oWD_rng = wdDoc.Range
With oWD_rng.Find
.ClearFormatting
.Style = wdDoc.Styles(-2)
.Text = "APPENDIX"
.Forward = True
.Wrap = 0
.Execute
End With

If oWD_rng.Find.Found Then
lRngEnd = oWD_rng.Start
Set oWD_rng = wdDoc.Range(lRngStart, lRngEnd)

For Each oWD_Table In oWD_rng.Tables
With ThisWorkbook
Set wksNewSheet = _
.Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
End With
oWD_Table.Range.Copy
wksNewSheet.Paste wksNewSheet.Range("A1")
Next
End If
End If
Loop Until Not oWD_rng.Find.Found
End Sub


Hope that helps,

Mark

[Ann_BBO]

Hi GTO,

Thanks for your great help. I have solved it by inserting the bookmarks in target headings and then base on the bookmarks, we can copy all tables between 2nd and 3rd heading as well. Here is the code.
Private Sub CommandButton3_Click()
Dim wdRng As Object
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
Set wdDoc = wdApp.Documents.Open(ListBox1.List(x))
wdApp.Visible = True
wdApp.Visible = True
Set wdRng = wdApp.Selection
wdRng.Find.Style = wdDoc.Styles("Heading 1")
wdRng.Find.Text = "SYSTEM PARAMETERS"
wdRng.Find.Forward = True
wdRng.Find.Wrap = wdFindAsk
wdRng.Find.Format = True
wdRng.Find.MatchCase = False
wdRng.Find.MatchWholeWord = False
wdRng.Find.MatchByte = False
wdRng.Find.MatchWildcards = False
wdRng.Find.MatchSoundsLike = False
wdRng.Find.MatchAllWordForms = False
wdRng.Find.Execute
wdRng.MoveRight

With wdDoc.Bookmarks
.Add Range:=wdRng.Range, Name:="Start"
.DefaultSorting = wdSortByName
.ShowHidden = False
End With
wdRng.Find.Style = wdDoc.Styles("Heading 1")
wdRng.Find.Text = "APPENDIX"
wdRng.Find.Forward = True
wdRng.Find.Wrap = wdFindAsk
wdRng.Find.Format = True
wdRng.Find.MatchCase = False
wdRng.Find.MatchWholeWord = False
wdRng.Find.MatchByte = False
wdRng.Find.MatchWildcards = False
wdRng.Find.MatchSoundsLike = False
wdRng.Find.MatchAllWordForms = False
wdRng.Find.Execute
wdRng.MoveUp
With wdDoc.Bookmarks
.Add Range:=wdRng.Range, Name:="End"
.DefaultSorting = wdSortByName
.ShowHidden = False
End With
Set aRange = wdDoc.Range( _
Start:=wdDoc.Bookmarks("Start").Range.End + 1, _
End:=wdDoc.Bookmarks("End").Range.Start - 1)
aRange.Copy
Workbooks.Add
ActiveSheet.Paste
Call ClearClipboard

wdDoc.Close savechanges:=False
wdApp.Quit
Set wdApp = Nothing
Call Copy_adjust

End Sub

Thanks for your help
Ann