Hi Guys

Is it possible to copy a word table into excel. I have a folder with circa
200 files that I need to import into Excel. I have got the code to access
word but am struggling to copy the tables.

Cheers

I found some macro in my archieves, but not sure if I ever got them
fully running. You are welcomed to try them

Sub Test()
Set ExSht = ActiveSheet
'
FName = "c:\temp\abc.doc"
WordWasRunning = True

On Error Resume Next
Set WDApp = GetObject(, "Word.Application")
If Err.Number < 0 Then
Set WDApp = CreateObject("Word.Application")
WordWasRunning = False
End If

WDApp.Visible = True 'at least for testing!

Set WDDoc = WDApp.documents.Open(Filename:=FName)
RowCount = 1
For Each Table In WDDoc.tables
For Each rw In Table.Rows
ColCount = 1
For Each Cell In rw.Cells

Set rngtext = Cell.Range
rngtext.MoveEnd Unit:=wdCharacter, Count:=-1
ExSht.Cells(RowCount, ColCount) = rngtext
ColCount = ColCount + 1
Next Cell
RowCount = RowCount + 1
Next rw
Next Table
Set WordTable = WDDoc.tables(1)
WDDoc.Close
WDApp.Quit
End Sub


Sub Test()
Set ExSht = ActiveSheet
'
FName = "c:\temp\abc.doc"
WordWasRunning = True

On Error Resume Next
Set WDApp = GetObject(, "Word.Application")
If Err.Number < 0 Then
Set WDApp = CreateObject("Word.Application")
WordWasRunning = False
End If

WDApp.Visible = True 'at least for testing!

Set WDDoc = WDApp.documents.Open(Filename:=FName)
RowCount = 1
For Each Table In WDDoc.tables
Table.Copy
ExSht.Range("A1").Paste
Next Table

WDDoc.Close
WDApp.Quit
End Sub


--
joel
------------------------------------------------------------------------
joel's Profile: http://www.thecodecage.com/forumz/member.php?u=229
View this thread: http://www.thecodecage.com/forumz/sh...d.php?t=197465

http://www.thecodecage.com/forumz

Here is code that I used for a specific project; you may have to adapt it a
little to get it working for your needs. The directory path was in cell A1 in
one of the sheets, and it cycled Word files and extracted data from each. It
also extracts formfield data.

The person who created the document I was extracting used nested tables
(ugh), so this code takes that into account, if you have the same problem.

HTH,
Keith

Option Base 1

Public UseCol
Public WhichCol
Public SArr As Variant
Public PasteRow

Sub UseFFLDOnly()
Dim wdDoc As String
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim wTable As Word.Table
Dim tRangeText As String, tRange As Word.Range
Dim p As Long, r As Long
Dim cSht As Worksheet

UsePath = Sheet3.Range("A1").Value
wdDoc = Dir(path & "\*.doc*")

Do While wdDoc < ""
'Open the document
Set wrdDoc = WdApp.Documents.Open(path & "\" & wdDoc)

Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open(strPath)

WhichCol = 0
PasteRow1 = Find_Last(Sheet1) + 1
PasteRow2 = Find_Last(Sheet2) + 1
Dim ffld As Word.FormField
If wrdDoc.FormFields(1).Name = "EeName" Then
Set cSht = Sheet1
UseRowCount = PasteRow1
Else
Set cSht = Sheet2
UseRowCount = PasteRow2
End If


For Each ffld In wrdDoc.FormFields
WhichCol = WhichCol + 1
ConvertCol (WhichCol)
'Debug.Print ffld.Result
If UseRowCount 2 Then
If cSht.Range(UseCol & 1).Value < ffld.Name Then
MsgBox "Mismatched Field Name: Check for errors" &
Chr(13) & Chr(13) & _
"Row " & UseRowCount & " on Sheet " & cSht.Name
End If
End If
cSht.Range(UseCol & 1).Value = ffld.Name
cSht.Range(UseCol & UseRowCount).Value = ffld.Result
Next

wrdDoc.Close
'Get the next document
wdDoc = Dir()
Loop

MsgBox "Done", , "Processing completed"

End Sub

Sub CreateReport(path As String)
Dim wdDoc As String
Dim curDoc As Word.Document
'Get first document in directory
wdDoc = Dir(path & "\*.docx")
'Loop until we don't have anymore documents in the directory
Do While wdDoc < ""
'Open the document
Set curDoc = WdApp.Documents.Open(path & "\" & wdDoc)
'Get comments
DoComments curDoc
'Get revisions
DoRevisions curDoc
'Close the document
curDoc.Close
'Get the next document
wdDoc = Dir()
Loop
End Sub


Private Function Find_Last(sht As Worksheet)
Find_Last = sht.Cells.Find(What:="*", After:=sht.Range("A1"),
LookAt:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False).Row
End Function

Private Function ConvertCol(SourceNum)

MyColNum = SourceNum
'================================================= =================
'Translate Column header to usable letter as UseCol

ColMod = MyColNum Mod 26 'div column # by 26. Remainder is the
second letter
If ColMod = 0 Then 'if no remainder then fix value
ColMod = 26
MyColNum = MyColNum - 26
End If
intInt = MyColNum \ 26 'first letter
If intInt = 0 Then UseCol = Chr(ColMod + 64) Else _
UseCol = Chr(intInt + 64) & Chr(ColMod + 64)
'================================================= =================

End Function

Sub Folder_Listing_Wrapper()
Const ParentFolderPath As String =
"C:\Users\Henry\Documents\Transfer\Work Files\Current Work\"
Call Folder_Listing(ParentFolderPath)
End Sub


Sub Folder_Listing(ParentFolderPath As String)

Dim FSO As Object, FolderSubFolder As Object, FolderFile As Object
Set FSO = CreateObject("Scripting.FileSystemObject")

For Each FolderSubFolder In FSO.GetFolder(ParentFolderPath).SubFolders
Debug.Print ParentFolderPath & FolderSubFolder.Name & "\"
Next FolderSubFolder

For Each FolderFile In FSO.GetFolder(ParentFolderPath).Files
Debug.Print ParentFolderPath & FolderFile.Name
Next FolderFile

End Sub



"JimmyA" wrote:

Hi Guys

Is it possible to copy a word table into excel. I have a folder with circa
200 files that I need to import into Excel. I have got the code to access
word but am struggling to copy the tables.

Cheers