Sub NotePad_to_word()
Dim sourceFile As Object
Dim myFilePath As String
Dim myFileText As String
Dim line As String

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim wrdSelection


myFilePath = "C:\Text-To-MsWord\Sample.txt"

    Set sourceFile = fso.OpenTextFile(myFilePath, ForReading)
    While Not sourceFile.AtEndOfStream 
        line = sourceFile.ReadLine

'''''How to get position of all Blank line nos
    Wend
    sourceFile.Close 

Set wrdApp = CreateObject("Word.Application")
    wrdApp.Visible = True
    Set wrdDoc = wrdApp.Documents.Add

Set wrdSelection = wrdApp.Selection
    wrdSelection.TypeText      '''''  DataAfterFrom in this Eg from Line 4 to Line 10

wrdDoc.Close
    wrdApp.Quit
End sub

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

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

  .Text = "[^13]{2,}"
  .Replacement.Text = "^p"

  .Text = "[^13]{2}[!^13]*[^13]{2}"
  .Replacement.Text = "^p"

DocTgt.Range.Characters.Last.Text = .Range.Text

Sub Demo4()
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

Option Explicit

Public Type SearchResults
    BlankLineNumber As Long
    CharPosition As Long
    StrLen As Long
End Type

Sub Example()
    Dim MySearch() As SearchResults, i As Long, txtToSrch As String
    
    txtToSrch = "[^13]"
    
    MySearch = GetSearchResults_2("C:\Text-To-MsWord\Sample.txt", txtToSrch, vbTextCompare)
    
    For i = 0 To UBound(MySearch)
        With MySearch(i)
            MsgBox "Blank Lines Are At " & vbCrLf & .BlankLineNumber
        End With
    Next
    
End Sub

Function GetSearchResults_2(FileFullName As String, FindThis As String, Optional CompareMethod As VbCompareMethod = vbBinaryCompare) As SearchResults()
  
    Dim fso As New FileSystemObject, s As String, pos As Long, l As Long, sr As SearchResults, ret() As SearchResults, i As Long
    Dim blnkLineNo As Long
    
    With fso.OpenTextFile(FileFullName)
        Do Until .AtEndOfStream
              l = l + 1
              s = .ReadLine
            pos = 1
            Do
                pos = InStr(pos, s, FindThis, CompareMethod)
                If pos > 0 Then
                    sr.CharPosition = pos
                    sr.BlankLineNumber = l
                    sr.StrLen = Len(FindThis)
                    
                    ReDim Preserve ret(i)
                    ret(i) = sr
                    i = i + 1
                    pos = pos + 1
                End If
            Loop Until pos = 0
        Loop
    End With
    GetSearchResults_2 = ret
End Function