Here is the coding I have per step listed in the original post.
Step 1:
Sub CombineAllWordDocs()
Dim baseDoc As Document, sFile As String
Dim oRng As Range
On Error GoTo err_Handler
Set baseDoc = Application.Documents.Add
sFile = Dir(sPath & "*.doc")
'Loop through all .doc files in that path
Do While sFile <> ""
Set oRng = baseDoc.Range
oRng.Collapse wdCollapseEnd
oRng.InsertFile sPath & sFile
Set oRng = baseDoc.Range
oRng.Collapse wdCollapseEnd
oRng.InsertBreak Type:=wdSectionBreakNextPage
sFile = Dir
DoEvents
Loop
MsgBox "Process complete"
lbl_Exit:
Set baseDoc = Nothing
Set oRng = Nothing
Exit Sub
err_Handler:
MsgBox Err.Number & vbCr & Err.Description
Err.Clear
GoTo lbl_Exit
End Sub
Step 2:
Sub Remove_Enter()
'
' Remove_Enter Macro
'
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p"
.Replacement.Text = " "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Step 3:
Missing Step
Step 4:
Sub Extract_Highlighted_Text()
'
' Extract_Highlighted_Text Macro
'
'
Debug.Print oNum 'This is the output list
Dim oDoc As Document
Dim s As String
With Selection
.HomeKey Unit:=wdStory
With .Find
.ClearFormatting
.Text = ""
.Highlight = True
Do While .Execute
s = s & Selection.Text & vbCrLf
Loop
End With
End With
Set oDoc = Documents.Add
oDoc.Range.InsertAfter s
End Sub
Step 5:
Copy and Paste to Excel
|