I tend to find it easier to write the procedure than to explain it, so here
is what I came up with-- not necessarily the best way to do it, but it works
.....(you may want to test it for special situations, like when there are no
accounts, or for when there are no positives for a particular account,
etc.). It actually turned out more complicated than I expected. To keep
things orderly I used 3 sheets:
"Accounts" to carry the original account information and to display the
final results;
"Scratch", as the name implies
"Results", a second "scratch" sheet to temporarily hold the output before
being transferred to the "Accounts" sheet.
The 2 scratch sheets are erased before the program ends.
The way it's set up now, you will have to clear the results columns on the
"Accounts" sheet before each run. You may just want to put the results into
a new workbook named for the date, or however you may like to do it.
HTH,
Shockley
Sub Tester()
With Sheets("Accounts")
LastRow = .Cells(65536, 1).End(xlUp).Row
Set rngSource = Range(.Cells(1, 1), _
.Cells(LastRow, 4))
End With
With Sheets("Scratch")
Set rngDest = Range(.Cells(2, 1), _
.Cells(LastRow + 1, 4))
End With
rngDest.Value = rngSource.Value
With Sheets("Scratch")
Do
p = 0
n = 0
FirstRow = .Cells(1, 1).End(xlDown).Row
If FirstRow = 65536 Then Exit Do
sAccount = .Cells(FirstRow, 1)
For i = FirstRow To LastRow + 1
If .Cells(i, 1) = sAccount Then
Set rngAccountLine = _
Range(.Cells(i, 1), .Cells(i, 4))
If .Cells(i, 4) > 0 Then
p = p + 1
If p < 6 Then _
MoveAccountLine rngAccountLine
End If
If .Cells(i, 4) < 0 Then
n = n + 1
If n < 6 Then _
MoveAccountLine rngAccountLine
End If
rngAccountLine.Value = Empty
End If
Next i
Set rngAccount = .Cells(1, 6).CurrentRegion
SortAccount rngAccount
MoveAccount rngAccount
rngAccount.Value = Empty
Loop
MoveResults
End With
End Sub
Sub MoveAccountLine(rng)
With Sheets("Scratch")
LastRow = .Cells(65536, 6).End(xlUp).Row
If .Cells(1, 6) = Empty Then LastRow = 0
Set rngDest = Range(.Cells(LastRow + 1, 6), _
.Cells(LastRow + 1, 9))
rngDest.Value = rng.Value
End With
End Sub
Sub SortAccount(rng)
With Sheets("Scratch")
bNeg = True
On Error Resume Next
FirstNegRow = .Columns(9).Find( _
What:="-", _
After:=.Cells(1, 9), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False).Row
If Err <> 0 Then bNeg = False
On Error GoTo 0
If .Cells(1, 9) < 0 Then FirstNegRow = 1
LastRow = .Cells(65536, 6).End(xlUp).Row
If .Cells(1, 9) > 0 Then
Set rngPos = Range(.Cells(1, 6), _
.Cells(FirstNegRow - 1, 9))
Else: Set rngPos = Nothing
End If
If bNeg = True Then
Set rngNeg = Range(.Cells(FirstNegRow, 6), _
.Cells(LastRow, 9))
Else: Set rngNeg = Nothing
End If
If Not rngPos Is Nothing Then _
rngPos.Sort _
Key1:=rngPos.Cells(1, 4), _
Order1:=xlDescending, _
Header:=xlNo, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
If Not rngNeg Is Nothing Then _
rngNeg.Sort _
Key1:=rngNeg.Cells(1, 4), _
Order1:=xlAscending, _
Header:=xlNo, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End With
End Sub
Sub MoveAccount(rng)
With Sheets("Results")
RowCount = rng.Rows.Count
LastRow = .Cells(65536, 1).End(xlUp).Row
If .Cells(1, 1) = Empty Then LastRow = 0
Set rngDest = Range(.Cells(LastRow + 1, 1), _
.Cells(LastRow + RowCount, 4))
rngDest.Value = rng.Value
End With
End Sub
Sub MoveResults()
With Sheets("Results")
Set rngResults = .Cells(1, 1).CurrentRegion
RowCount = rngResults.Rows.Count
End With
With Sheets("Accounts")
Set rngDest = Range(.Cells(1, 6), _
.Cells(RowCount, 9))
End With
rngDest.Value = rngResults.Value
rngResults.Value = Empty
End Sub
