If the problem is unwanted end of paragraph marks in the table, use
replace to replace the paragraph marks (^p) with nothing first.
http://www.gmayor.com/batch_replace.htm, You could use the same macro to
convert the table to text and save the resulting file as a comma delimited
text file (csv) in the same folder, which should import directly into
Access. If you prefer the filename to have a txt extension, change the two
instances of csv to txt in the lines The original documents will be
unaffected by the process.
If LCase(Right(sFName, 1)) = "x" Then
sFName = Left(sFName, Len(sFName) - 4) & "csv"
Else
sFName = Left(sFName, Len(sFName) - 3) & "csv"
End If
The following is based on the code from my web page where the various
contributions to it are attributed.
Put all the table documents in a folder and select that folder when you
run the macro. It assumes that the document contains a single table and
that any paragraph marks it contains are unwanted.
http://www.gmayor.com/installing_macro.htm
Public Sub BatchReplaceAnywhere()
Dim FirstLoop As Boolean
Dim myFile As String
Dim sFName As String
Dim strPath As String
Dim myDoc As Document
Dim rngstory As Word.Range
Dim findText As String
Dim Replacement As String
Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
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
'Close any documents that may be open
If Documents.Count > 0 Then
Documents.Close SaveChanges:=wdPromptToSaveChanges
End If
FirstLoop = True
myFile = Dir$(strPath & "*.doc")
While myFile <> ""
'Get the text to be replaced and the replacement
findText = "^p"
Replacement = ""
'Open each file and make the replacement
Set myDoc = Documents.Open(strPath & myFile)
' Fix the skipped blank Header/Footer problem
MakeHFValid
' Iterate through all story types in the current document
For Each rngstory In ActiveDocument.StoryRanges
' Iterate through all linked stories
Do
SearchAndReplaceInStory rngstory, findText, Replacement
' Get next linked story (if any)
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
'Close the file, saving the changes.
With myDoc
.Tables(1).ConvertToText ","
sFName = .FullName
If LCase(Right(sFName, 1)) = "x" Then
sFName = Left(sFName, Len(sFName) - 4) & "csv"
Else
sFName = Left(sFName, Len(sFName) - 3) & "csv"
End If
.SaveAs FileName:=sFName, fileformat:=wdFormatText
.Close
End With
myFile = Dir$()
Wend
End Sub
Public Sub SearchAndReplaceInStory(ByVal rngstory As Word.Range, _
ByVal strSearch As String, _
ByVal strReplace As String)
'This routine supplied by Peter Hewett
Do Until (rngstory Is Nothing)
With rngstory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strSearch
.Replacement.Text = strReplace
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.Execute Replace:=wdReplaceAll
End With
Set rngstory = rngstory.NextStoryRange
Loop
End Sub
Public Sub MakeHFValid()
'And this too
Dim lngJunk As Long
' It does not matter whether we access the Headers or Footers property.
' The critical part is accessing the stories range object
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
End Sub
--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP
My web site
www.gmayor.com
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
