View Single Post
 
Old 01-11-2022, 06:19 PM
Mr J Mr J is offline Windows 10 Office 2016
Novice
 
Join Date: Aug 2020
Location: California, US
Posts: 15
Mr J is on a distinguished road
Default

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
Reply With Quote