Need to apply Heading1 to select rows

[bobk544]

Hello, i need to apply the Heading1 style to every every row that has the text string of
"C:\_XREF_ALL\App.2018" and the result i'm hoping for is that i will be able to collapse and expand the rows under each Heading1. And basically, this document contains a lot of program code and the beginning of each program starts with the C drive directory reference ie C:\_XREF_ALL\App.2018\Program1 for example. So i'm hoping that when i apply the Heading1 to the full row, i will be able to expand and collapse each program section of code, thanks for any help on this!

Sub HeaderApply()
Application.ScreenUpdating = False
Dim StrFnd As String, StrSty As String, StrRep As String, i As Long
StrFnd = "C:\_XREF_ALL\App.2018"
StrSty = " Strong,Heading 1,Character Style 1,Italic,Character Style 2"
StrRep = "Placeholder1^& Placeholder2,^&,^&,Placeholder3^& Placeholder4,^&"
With ActiveDocument.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Forward = True
  .Format = True
  .Wrap = wdFindContinue
  .MatchWildcards = True
  .Text = ActiveDocument.Range  'trying to get the whole row text here
  .Replacement.Style = StrSty
  .Execute Replace:=wdReplaceAll
  'For i = 0 To UBound(Split(StrFnd, ","))
  '  .Text = "#" & Split(StrFnd, ",")(i) & "[A-Za-z]@>"
  '  .Replacement.Style = Split(StrSty, ",")(i)
  '  .Replacement.Text = Split(StrRep, ",")(i)
  '  .Execute Replace:=wdReplaceAll
  'Next
End With
Application.ScreenUpdating = True
End Sub