If the aim is simply to write all the non-empty lines to the active document, you could use code like:
Code:
Sub Demo1()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document
Set DocTgt = ActiveDocument: Set DocSrc = Documents.Open(FileName:="C:\Text-To-MsWord\Sample.txt", AddToRecentFiles:=False, Visible:=False)
With DocSrc
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Forward = True
.Wrap = wdFindContinue
.MatchWildcards = True
.Text = "[^13]"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Text = "[^13]{2,}"
.Execute Replace:=wdReplaceAll
End With
DocTgt.Range.Characters.Last.Text = .Text
End With
.Close False
End With
Application.ScreenUpdating = True
End Sub
Alternatively, if the aim is to write only the content between the first & second set of empty lines to the active document, you could use code like:
Code:
Sub Demo()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document
Set DocTgt = ActiveDocument: Set DocSrc = Documents.Open(FileName:="C:\Text-To-MsWord\Sample.txt", AddToRecentFiles:=False, Visible:=False)
With DocSrc
With .Range
With .Find
.Format = False
.Forward = True
.Wrap = wdFindContinue
.MatchWildcards = True
.Text = "[^13]"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Wrap = wdFindStop
.MatchWildcards = True
.Text = "[^13]{2}[!^13]*[^13]{2}"
.Replacement.Text = "^p"
.Execute
End With
If .Find.Found = True Then
DocTgt.Range.Characters.Last.Text = Replace(.Text, vbCr & vbCr, "")
End If
End With
.Close False
End With
Application.ScreenUpdating = True
End Sub
In either case, it is not necessary to know the start/end empty line positions.