HI,
My 2 cents...I modified excelledsoftware. All I did was shorten the code by using an "Array". This is just another way to code.
Code:
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