PDA

View Full Version : Importing data from Header and table in Word to Excel.



AndersW
03-12-2014, 03:20 PM
I have over 300 word documents with information I would like to import to an excel sheet for statistical use.
The information I need from the Word document is found in the Header of the document and in the table of the document.
I am very new to macro and have only manage to find som scripts that imports the table, but then only from on document.
I could put all the word documents into one folder so that the macro could import all documents from the same location.
I have attached a template of the document template I am using. The areas that are highlighted is the information I need to have over to the excel sheet.
The table can be imported directly, but the information in the Header has to be beside each row from the table in their own column.
When the information has been imported it shall continue with the next word document and insert it bellow the previus imported information in the excel sheet.

AndersW
03-12-2014, 03:21 PM
And here is a picture of how I hope it will look like after importing
11392

westconn1
03-13-2014, 03:08 AM
I could put all the word documents into one folder so that the macro could import all documents from the same location.working on that assumption, you can try like

mypath = "c:\temp\"
Set wd = CreateObject("word.application")
fname = Dir(mypath & "*.doc")
Do While Len(fname) > 0
Set doc = wd.documents.Open(mypath & fname)
st = Cells(Rows.Count, 1).End(xlUp).Row + 1
With doc.sections(1).headers(1).Range.tables(1)
h1 = Replace(Replace(Replace(.cell(3, 2).Range.Text, Chr(7), ""), Chr(9), ""), Chr(13), "")
h2 = Trim(Replace(Replace(Replace(.cell(5, 2).Range.Text, Chr(7), ""), Chr(9), ""), Chr(13), ""))
h3 = Trim(Replace(Replace(Replace(.cell(7, 2).Range.Text, Chr(7), ""), Chr(9), ""), Chr(13), ""))
h4 = Trim(Replace(Replace(Replace(.cell(7, 4).Range.Text, Chr(7), ""), Chr(9), ""), Chr(13), ""))
End With
With doc.tables(1)
For rw = 1 To .Rows.Count - 2
For col = 1 To 4
Cells(rw + st, col).Value = Replace(Replace(.cell(rw, col).Range.Text, Chr(7), ""), Chr(13), "")
Next
Cells(rw + st, col).Value = Split(h1, " ")(0)
Cells(rw + st, col + 1).Value = Split(h1, " ")(2)
Cells(rw + st, col + 2).Value = h2
Cells(rw + st, col + 3).Value = h3
Cells(rw + st, col + 4).Value = h4
Next
End With
fname = Dir
Loop

snb
03-13-2014, 11:22 AM
If you put all files in the same folder (e.g. 'G:\OF\') you only have to change the name of that folder in the first line of this macro.


Sub M_snb()
c00 = "G:\OF\"
sn = Split(CreateObject("wscript.shell").exec("cmd /c dir """ & c00 & "*.doc"" /b").stdout.readall, vbCrLf)
For Each it In sn
With GetObject(c00 & it)
With .StoryRanges(7).tables(1)
c01 = "|" & .cell(3, 2).Range.Text & "|" & .cell(5, 2).Range.Text & "|" & .cell(7, 4).Range.Text & "|" & .cell(7, 2).Range.Text
End With
With .tables(1)
For j = 1 To .Rows.Count
If .cell(j, 1) = "" Then Exit For
c02 = c02 & vbCr & Replace(Replace(.cell(1, 1) & "|" & .cell(1, 2) & "|" & .cell(1, 3) & "|" & .cell(1, 4) & c01, vbCr & Chr(7), ""), Chr(150), "|")
Next
End With
.Close 0
End With
Next

sn = Split(Mid(c02, 2), vbCr)
Cells(1).Resize(UBound(sn) + 1) = Application.Transpose(sn)
Columns(1).TextToColumns , , , , 0, 0, 0, 0, -1, "|"
End Sub

AndersW
03-14-2014, 12:14 PM
Wow. Thanks to both westconn1 and snb.
Ended up using westconn1's code. I just had to add a closing to the last opened Word document. Since Winword.exe stayed open after i run the macro. When I then tried to re-run it, it failed due to the open winword.exe file.

Sub ImportPunches()
mypath = "D:\Temp\"
Set wd = CreateObject("word.application")
wd.Visible = False 'NEW
fname = Dir(mypath & "*.doc")
Do While Len(fname) > 0
Set doc = wd.documents.Open(mypath & fname, ReadOnly:=True) ' Added ReadOnly
st = Cells(Rows.Count, 1).End(xlUp).Row + 1
With doc.sections(1).headers(1).Range.tables(1)
h1 = Replace(Replace(Replace(.cell(3, 2).Range.Text, Chr(7), ""), Chr(9), ""), Chr(13), "")
h2 = Trim(Replace(Replace(Replace(.cell(5, 2).Range.Text, Chr(7), ""), Chr(9), ""), Chr(13), ""))
h3 = Trim(Replace(Replace(Replace(.cell(7, 2).Range.Text, Chr(7), ""), Chr(9), ""), Chr(13), ""))
h4 = Trim(Replace(Replace(Replace(.cell(7, 4).Range.Text, Chr(7), ""), Chr(9), ""), Chr(13), ""))
End With
With doc.tables(1)
For rw = 1 To .Rows.Count - 2
For col = 1 To 4
Cells(rw + st, col).Value = Replace(Replace(.cell(rw, col).Range.Text, Chr(7), ""), Chr(13), "")
Next
Cells(rw + st, col).Value = Split(h1, " ")(0)
Cells(rw + st, col + 1).Value = Split(h1, " ")(2)
Cells(rw + st, col + 2).Value = h2
Cells(rw + st, col + 3).Value = h3
Cells(rw + st, col + 4).Value = h4
Next
End With
fname = Dir
Loop
'Close everything
doc.Close
Set doc = Nothing
wd.Quit
Set wd = Nothing
End Sub

westconn1
03-14-2014, 10:50 PM
I just had to add a closing to the last opened Word documentit would be better to close each document within the loop, omission on my part
while wd.quit closes all within that instance of word, if many are opened you could run short on memory during the loop

AndersW
03-15-2014, 03:01 AM
Again thank you. I will try to do so. Any how, I am very gratefull for your help.