Move Subtotal to the top

I have this simple code which works fine but now I've been twisting around the code attempt to move the subtotal to the top on each summed up items but couldn't get works. any help would be appreciated. I would like the outcome as shown on "Result" sheet. Thansk

Sub Subtotals()

  Dim LastRow As Long
  Dim NextV As String
  Dim R As Long
  Dim Rng As Range
  Dim SubAmount As Currency
  Dim ThisV As String
  Dim TotalAmount As Currency
  Dim Wks As Worksheet
  
    Set Wks = Worksheets("Reconciliation")
    LastRow = Wks.Cells(Rows.Count, "A").End(xlUp).Row
    Set Rng = Wks.Range(Cells(9, "A"), Cells(LastRow, "D"))
    
    Rng.Sort Key1:=Wks.Range("B8")
    R = 9
    
    With Wks
      Do While .Cells(R, "B").Value <> ""
       SubAmount = SubAmount + .Cells(R, "D").Value
       ThisV = Format(.Cells(R, "B"), "#.#")
       NextV = Format(.Cells(R + 1, "B"), "#.#")
          If ThisV <> NextV Then
             .Cells(R + 1, "B").EntireRow.Insert shift:=xlShiftDown
               With .Cells(R + 1, "C")
                 .Value = "Subtotal for Voucher " & ThisV
                 .Font.Bold = True
               End With
               With .Cells(R + 1, "D")
                 .Font.Bold = True
                 .Value = SubAmount
               End With
             TotalAmount = TotalAmount + SubAmount
             SubAmount = 0
             R = R + 2
          Else
             R = R + 1
          End If
      Loop
      .Cells(R, "C").Value = "Total"
      .Cells(R, "C").Font.Bold = True
      .Cells(R, "D").Value = TotalAmount
      .Cells(R, "D").Font.Bold = True
      With .Range(.Cells(R - 1, "A"), .Cells(R - 1, "D"))
        .BorderAround LineStyle:=xlContinuous, Weight:=xlThin
          With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
          End With
      End With
    End With
    
End Sub