Sub ParseAgreements()
  'searches through all sorted records of a table
  'and exports the results in a 1 record per row
  'result.
  
  Dim EndRngRow As Long, CheckRow As Long
  Dim ResultRow As Long
  Dim FoundEndRow As Boolean
  Dim FindCol As Integer, StartRngRow As Integer, BegRow As Integer
  Dim Col As Integer
  Dim ValString As String, AgreementNum As String, ColData(11) As String
  Dim ws As Worksheet, rws As Worksheet
  Dim wb As Workbook
  
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet1") 'worksheet with data.
    Set rws = wb.Worksheets("Sheet2") 'worksheet for result.
  
    StartRngRow = 2 'Change if your data starts below row 2
    ResultRow = 2
    BegRow = StartRngRow - 1
    On Error GoTo 0 'Put errors back to normal
    'Convert the found column to a string
    If Range("D" & StartRngRow - 1).Value <> "Agreement/Subs Num" Then
      MsgBox "The Agreement Sub column is not in D" & _
      StartRngRow - 1 & vbLf & _
      "This program is coded to work with column D" & vbLf & _
      "Program Ending"
      End
    End If
    
    'Set up the results headers
    rws.Range("A1:Z30000").ClearContents
   '''' Modified '''
    rws.Range("A1:K1").Value = Array("Legacy Number", "Alternative Lease Number", _
        "Agreement Number", "Agreement/Subs Num", "Property Status", "Immediate Predecessor", "Book", "Term Length (Months)", "Total Bonus Amount", "Lease Memo")
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    CheckRow = StartRngRow
    ws.Activate
    ws.Range("D" & CheckRow).Select
    Selection.CurrentRegion.Select
    Selection.Sort Key1:=Range("D" & CheckRow), Order1:=xlAscending, _
    Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    CheckRow = StartRngRow
    Do
      AgreementNum = ws.Range("D" & StartRngRow).Value
      FoundEndRow = False
        Do Until FoundEndRow = True
          If ws.Range("D" & CheckRow).Value <> AgreementNum Then
            EndRngRow = CheckRow - 1
            FoundEndRow = True
          End If
          If ws.Range("D" & CheckRow).Value = "" Then
            FoundEndRow = True 'end the loop
          End If
          CheckRow = CheckRow + 1
        Loop
        For CheckRow = StartRngRow To EndRngRow
          For Col = 1 To 11
            If ws.Cells(CheckRow, Col).Value <> "" Then
              ColData(Col) = ws.Cells(CheckRow, Col).Value
            End If
          Next Col
        Next CheckRow
        'export the results
        For Col = 1 To 11
          rws.Cells(ResultRow, Col).Value = ColData(Col)
        Next Col
        'get ready for the next batch
        For Col = 0 To 11
          ColData(Col) = ""
        Next Col
        ResultRow = ResultRow + 1
        StartRngRow = CheckRow
    Loop Until ws.Range("D" & CheckRow).Value = ""
    rws.Activate
     
End Sub