bplejic
04-22-2008, 01:53 AM
Hi all,
I'm trying to store data from several word docs (text data) to table in word file. Everything looks fine until the end when I get run time error 5825 and my table is deleted. Please help. Thank You and if You know how I can save those data not just to table but also into MS access database table just write the answer.
Here is my code until now :
Sub ExtractData()
Dim sDTE As String
Dim sSubject As String
Dim strFileName As String
Dim strPath As String
Dim oDoc As Word.Document
Dim dataDoc As Document
Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
'Pick the folder with the letters
With fDialog
.Title = "Select Folder containing the documents to be modifed and click OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User"
Exit Sub
End If
strPath = fDialog.SelectedItems.Item(1)
If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
End With
strFileName = Dir$(strPath & "*.doc")
'Assign the name of the document to take the data
Documents.Open ("""C:\MagRad\Rez.doc""")
Set dataDoc = ActiveDocument
'Open the letters in turn
While strFileName <> ""
Set oDoc = Documents.Open(strPath & strFileName)
Selection.HomeKey wdStory 'Start from the top of the letter
With Selection.Find 'find the first string
.ClearFormatting
Do While .Execute(findText:="DTE/*^13", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
'Assign the found text to a variable and chop off
'the last character - '?'
sDTE = Left(Selection.Range, Len(Selection.Range) - 1)
Loop
End With
Selection.HomeKey wdStory 'Start from the top of the letter
With Selection.Find 'find the second string
.ClearFormatting
Do While .Execute(findText:="Subject :*^13", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
'Assign the second string to a variable and chop off
'the last character and the leading text
sSubject = Mid(Selection.Range, 10, Len(Selection.Range) - 10)
Loop
End With
'Switch to the data document and add the content of
'the variables to the blank row of the table
dataDoc.Activate
With Selection
.EndKey wdStory
.MoveUp Unit:=wdLine, Count:=1
.MoveRight Unit:=wdCell, Count:=2 'Add a new blank row
.TypeText Text:=sDTE
.MoveRight Unit:=wdCell
.TypeText Text:=sSubject
End With
'Close the letter without saving
oDoc.Close SaveChanges:=wdDoNotSaveChanges
Set oDoc = Nothing
strFileName = Dir$()
Wend
dataDoc.Save :( Here error message jumped and table is deleted
End Sub
Thank You
I'm trying to store data from several word docs (text data) to table in word file. Everything looks fine until the end when I get run time error 5825 and my table is deleted. Please help. Thank You and if You know how I can save those data not just to table but also into MS access database table just write the answer.
Here is my code until now :
Sub ExtractData()
Dim sDTE As String
Dim sSubject As String
Dim strFileName As String
Dim strPath As String
Dim oDoc As Word.Document
Dim dataDoc As Document
Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
'Pick the folder with the letters
With fDialog
.Title = "Select Folder containing the documents to be modifed and click OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User"
Exit Sub
End If
strPath = fDialog.SelectedItems.Item(1)
If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
End With
strFileName = Dir$(strPath & "*.doc")
'Assign the name of the document to take the data
Documents.Open ("""C:\MagRad\Rez.doc""")
Set dataDoc = ActiveDocument
'Open the letters in turn
While strFileName <> ""
Set oDoc = Documents.Open(strPath & strFileName)
Selection.HomeKey wdStory 'Start from the top of the letter
With Selection.Find 'find the first string
.ClearFormatting
Do While .Execute(findText:="DTE/*^13", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
'Assign the found text to a variable and chop off
'the last character - '?'
sDTE = Left(Selection.Range, Len(Selection.Range) - 1)
Loop
End With
Selection.HomeKey wdStory 'Start from the top of the letter
With Selection.Find 'find the second string
.ClearFormatting
Do While .Execute(findText:="Subject :*^13", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
'Assign the second string to a variable and chop off
'the last character and the leading text
sSubject = Mid(Selection.Range, 10, Len(Selection.Range) - 10)
Loop
End With
'Switch to the data document and add the content of
'the variables to the blank row of the table
dataDoc.Activate
With Selection
.EndKey wdStory
.MoveUp Unit:=wdLine, Count:=1
.MoveRight Unit:=wdCell, Count:=2 'Add a new blank row
.TypeText Text:=sDTE
.MoveRight Unit:=wdCell
.TypeText Text:=sSubject
End With
'Close the letter without saving
oDoc.Close SaveChanges:=wdDoNotSaveChanges
Set oDoc = Nothing
strFileName = Dir$()
Wend
dataDoc.Save :( Here error message jumped and table is deleted
End Sub
Thank You