View Full Version : Solved: Copy the table in Word document to NEW Excel file
Ann_BBO
10-13-2009, 02:17 AM
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®ards,
Ann
Ann_BBO
10-13-2009, 09:00 AM
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
10-13-2009, 08:49 PM
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
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
10-14-2009, 12:56 AM
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
10-15-2009, 07:38 PM
Partial solution here (http://www.vbaexpress.com/forum/showthread.php?t=28801)
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
10-18-2009, 09:33 PM
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.