Correct ordering bug in macro

I need some assistance in fixing the macro below that is also contained in this Excel sheet.
Please don't upload the sheet itself if you can keep from it, but rather just paste in the corrected code. I greatly appreciate the help.

DEFINITIONS:
Legs are made up of individual rows within a Spread.
Spreads can be made up of more than one Leg.
Positions can be made up of more than one Spread.

INDEXING - The indexing described below appears to be correct.

Each Position, Spread, and Leg is indexed with a number according to the value in it's Exec Date column.
Positions are numbered sequentially with 1 being  meaning that it contains a newer Exec Date than any other positions.  
Spreads are numbered sequentially with 1 meaning that it contains the a newer Exec Date than the other spreads.  
Legs are numbered sequentially with 1 containing the oldest Exec Date within it's particular spread and starting over at the next spread.
If the Exec Date column (which is actually a date and time stamp) contains the same values, then the Symbol is used in with A at the top.

ORDERING - The ordering described below appears to be correct now with one exception.

Positions can contain multi-leg spreads but, the order of the legs 'within' each spread never changes.
The order in which each spread appears within the overall position does change.
Almost Correct:  *The oldest spreads should appear at the top of the position and the newer spreads should appear at the bottom of the position.  Most are correct but something is still off as illustrated in this video >> http://screencast.com/t/1i5OQGssgfh.

Thank you for the assist.
Option Explicit
'--> This macro takes either pm or rm tabs and creates a properly formatted table in a new tab'
'called Output.'

'The table data contained in Output is based on the Trade History section of the original tab.'
'It is important to note that the legs (rows) of each spread are numbered and remain in the same order'
'just as they appear in the original tab. The spreads are then numbered as well and moved into'
'individually numbered positions'. When the end user filters the sheet, these positions (which can'
'contain multiple spreads) remain together, and the numbered columns representing the Spread numbers'
'and Position numbers are intended to be hidden for greater readability.'

'Future development will include hiding the Leg and Spread numbers, as well as making some
'calculations on each overall position.'

Const AOH = "Account Order History"
Const ATH = "Account Trade History"
Const PAL = "Profits and Losses"
Const EQT = "Equities"
Const OPT = "Options"
Dim wsopt As Worksheet
    
Sub TradeReport()
    Dim wsPM As Worksheet
    Dim aCell As Range, bCell As Range, cCell As Range, delRange As Range
    Dim AOHRow As Long, PALRow As Long, ATHRow As Long
    Dim LastRow As Long, i As Long, j As Long
    Dim shName As String
    Dim SearchString As String, MatchString As String, init1String As String, init2String As String
    Dim intNum  As Long
    
    On Error GoTo Whoa
    
    Application.ScreenUpdating = False
    
    Set wsPM = ActiveSheet
    
    shName = wsPM.Name
        
    '--> Make New "Output" Sheet if one already exists'
    On Error Resume Next
    Application.DisplayAlerts = False
    Set wsopt = Sheets("Output")
    intNum = 0
    While Err.Number = 0
        Err.Clear
        intNum = intNum + 1
        Set wsopt = Sheets("Output" & intNum)
    Wend
    Err.Clear
    On Error GoTo 0
    Application.DisplayAlerts = True
    
    '--> Recreate "Output" Sheet and move it to the right'
    Set wsopt = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    If intNum = 0 Then
        wsopt.Name = "Output"
    Else
        wsopt.Name = "Output" & intNum
    End If
    
    '--> Find the "Account Trade History" cell in Sheet PM'
    Set aCell = wsPM.Columns(1).Find(What:=ATH, LookIn:=xlFormulas, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    
    '--> If "Account Trade History" is found'
    If Not aCell Is Nothing Then
        '--> Get the starting row of "Account Trade History"'
        ATHRow = aCell.Row
        
        '--> Find the "Profits and Losses" cell in Sheet PM'
        Set bCell = wsPM.Columns(1).Find(What:=PAL, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
        If shName = "rm" Then
            '--> Find the "Equities" cell in Sheet RM'
            Set bCell = wsPM.Columns(1).Find(What:=EQT, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        Else
            '--> Find the "Options" cell in Sheet PM'
            Set bCell = wsPM.Columns(1).Find(What:=OPT, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        End If
        
        
        '--> If "Profits and Losses" is found'
        If Not bCell Is Nothing Then
            '--> Get the starting row of "Profits and Losses"
            PALRow = bCell.Row
            
            '--> Output Trade History to new tab.'
            wsPM.Rows((ATHRow + 1) & ":" & (PALRow - 1)).Copy wsopt.Rows(1)
            
            If shName = "rm" Then
                wsopt.Select
                Columns("A:A").Select
                Selection.Insert Shift:=xlToRight
            End If
            
            With wsopt
                '--> Remove last three columns because they are duplicates.'
                .Columns("M:O").Delete Shift:=xlToLeft
                
                '--> Define the notes column.'
                .Range("A1").Value = "Notes"
                .Columns("A:A").Replace What:="DEFAULT", Replacement:="", LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
                
                '--> Get the last row of Output Sheet'
                LastRow = .Cells.Find(What:="*", after:=[A1], SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious).Row
                   
                '--> Unsure of what this section does?'
                Set cCell = wsPM.Columns(1).Find(What:=AOH, LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
                
                If Not cCell Is Nothing Then
                    AOHRow = cCell.Row + 1
                    
                '--> Copy the notes into the new notes column.'
                    For i = AOHRow To ATHRow
                        SearchString = wsPM.Range("D" & i).Value & "###" & _
                        wsPM.Range("F" & i).Value & "###" & _
                        wsPM.Range("G" & i).Value & "###" & _
                        wsPM.Range("H" & i).Value & "###" & _
                        wsPM.Range("I" & i).Value
                
                        init1String = wsPM.Range("F" & i).Value
                
                        For j = 2 To LastRow
                            init2String = wsopt.Range("F" & j).Value
                
                            If init1String = init2String Then
                                MatchString = .Range("D" & j).Value & "###" & _
                                              .Range("F" & j).Value & "###" & _
                                              .Range("G" & j).Value & "###" & _
                                              .Range("H" & j).Value & "###" & _
                                              .Range("I" & j).Value
                
                                If MatchString = SearchString Then
                                    .Range("A" & j).Value = wsPM.Range("A" & i).Value
                                End If
                            End If
                        Next j
                    Next i
                End If
                
                '--> Make the Output tab into a table that can be filtered by the column headers.'
                .ListObjects.Add(xlSrcRange, Range("$A$1:$L$" & LastRow), , xlYes).Name = "Table1"
                .ListObjects("Table1").ShowTableStyleRowStripes = False
                'ListObjects("Table1").TableStyle = "TableStyleLight1"'
                .Columns("B:L").EntireColumn.AutoFit
                
            End With
        End If
    End If
    Application.ScreenUpdating = False
    NewUpdates
    Indexing
    Sorting
    Application.ScreenUpdating = True
    
'--> Clean Up and Exit.'
LetsContinue:
    Application.ScreenUpdating = True
    Set aCell = Nothing: Set bCell = Nothing: Set cCell = Nothing: Set delRange = Nothing
    On Error Resume Next
    Set wsopt = Nothing: Set wsPM = Nothing
    On Error GoTo 0
    Exit Sub
    
'--> Error Handling'
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub
Private Sub NewUpdates()
Dim i As Integer

'---> Create extra space at the top of the table of approximately 10 rows.
wsopt.Rows("1:10").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

'---> Modify the date format of the Exec Time column to reflect the format of ddd mmm dd, yyyy hh:mm'
'and the Exp column to reflect the format of mm-yy.'
For i = 12 To wsopt.Cells(wsopt.Rows.Count, "K").End(xlUp).Row
wsopt.Range("B" & i).NumberFormat = "ddd mmm-dd-yyyy hh:mm"
wsopt.Range("G" & i).NumberFormat = "mmm-yy"
Next i

'--> Add Columns for Postion, Spread, and Leg Numbers'
'Add P# column before the Exec Time column with the comment "Position #" in the header for the P# column.'
'Add  S# column between the Exec Time and Spread columns with the comment "Spread #" in the header for the S# column.'
'Add L# column between the Spread and Side columns with the comment "Leg #" in the header for the L# column.'
wsopt.Columns("B:B").Insert Shift:=xlToRight
wsopt.Columns("D:D").Insert Shift:=xlToRight
wsopt.Columns("F:F").Insert Shift:=xlToRight

'---> Format column D and E to number format
wsopt.Range("D12:D" & wsopt.Cells(wsopt.Rows.Count, "K").End(xlUp).Row).NumberFormat = "0"
wsopt.Range("F12:F" & wsopt.Cells(wsopt.Rows.Count, "K").End(xlUp).Row).NumberFormat = "0"
wsopt.Range("B12:B" & wsopt.Cells(wsopt.Rows.Count, "K").End(xlUp).Row).NumberFormat = "0"

'---> Rename the header of the added Position, Spread, and Leg Number columns'
wsopt.Range("B11") = "P#": wsopt.Range("D11") = "S#": wsopt.Range("F11") = "L#"

'---> Set autofit to the width of column D and E
wsopt.Columns("D:D").EntireColumn.AutoFit
wsopt.Columns("F:F").EntireColumn.AutoFit
wsopt.Columns("B:B").EntireColumn.AutoFit
'---> Add comments
wsopt.Range("B11").AddComment
wsopt.Range("B11").Comment.Visible = False
wsopt.Range("B11").Comment.Text Text:="Position No"
wsopt.Range("D11").AddComment
wsopt.Range("D11").Comment.Visible = False
wsopt.Range("D11").Comment.Text Text:="Spread No"
wsopt.Range("F11").AddComment
wsopt.Range("F11").Comment.Visible = False
wsopt.Range("F11").Comment.Text Text:="Leg No"

'---> Shrink the printout so all column will be printed in the same page
'Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
'Application.PrintCommunication = False
wsopt.PageSetup.FitToPagesWide = 1
wsopt.PageSetup.FitToPagesTall = 1
'Application.PrintCommunication = True

End Sub

Private Sub Indexing()

'--> Indexing macro - The Spread No should be a unique number per Spread (some spreads have multiple
'legs) with the lower numbers on the newest spreads and the highest numbers on the oldest spreads.'
'The legs of each spread should be numbered according to how many rows the Spread has starting'
'with the number 1 and should start over at number 1 again on the next spread. Note that each Spread'
'can have several Legs and Each Position can contain several Spreads. A Spread is part of the same'
'Position if any of it's Legs (rows) contain the same Symbol, Exp, Strike, and Type of any other'
'Spread in the sheet.'


Dim i As Integer, k As Double, z As Double, j As Double, l As Double, test As Boolean, test1 As Boolean
Dim ws As Worksheet, q As Double, Rcount As Double, x As Double, SpreadNo As Double
Sheets.Add after:=Sheets(Sheets.Count)
Set ws = Sheets(Sheets.Count)
k = 0: z = -1: Rcount = wsopt.Cells(wsopt.Rows.Count, "K").End(xlUp).Row: SpreadNo = 0

For i = 12 To Rcount

    If k = 0 And z = -1 Then
        k = k + 1: z = z + 2:
        ws.Cells(k, z) = wsopt.Range("I" & i) & wsopt.Range("J" & i) & wsopt.Range("L" & i) & " " & wsopt.Range("K" & i)
        For x = i + 1 To Rcount
        If wsopt.Range("C" & x) = "" Then
            If InStr(1, ws.Cells(k, z), wsopt.Range("K" & x)) = 0 Then ws.Cells(k, z) = ws.Cells(k, z) & " " & wsopt.Range("K" & x)
        Else
        Exit For
        End If
        Next x
        ws.Cells(k + 1, z) = wsopt.Range("C" & i) & wsopt.Range("E" & i)
        ws.Cells(k + 1, z + 1) = ws.Cells(k, z + 1) + 1
        wsopt.Range("B" & i) = 1:  wsopt.Range("F" & i) = 1
    Else
        If j = 0 Then j = 1
        If wsopt.Range("C" & i) = "" Then
            test = True
        Else
        test = False: q = -1
    For j = 1 To z Step 2
        q = q + 1
        If InStr(1, ws.Cells(1, j), wsopt.Range("I" & i) & wsopt.Range("J" & i) & wsopt.Range("L" & i)) > 0 Then
        If InStr(1, ws.Cells(1, j), wsopt.Range("K" & i)) > 0 Then
            wsopt.Range("B" & i) = j - q: test = True
            For x = i + 1 To Rcount
            If wsopt.Range("C" & x) = "" Then
                If InStr(1, ws.Cells(k, j), wsopt.Range("K" & x)) = 0 Then ws.Cells(k, j) = ws.Cells(k, j) & " " & wsopt.Range("K" & x)
            Else
            Exit For
            End If
            Next x
        Else
            For x = i + 1 To Rcount
            If wsopt.Range("C" & x) = "" Then
                If InStr(1, ws.Cells(k, j), wsopt.Range("K" & x)) > 0 Then wsopt.Range("B" & i) = j - q: test = True
            Else
            Exit For
            End If
            Next x
            If test = True Then
            ws.Cells(k, j) = ws.Cells(k, j) & " " & wsopt.Range("K" & i)
            For x = i + 1 To Rcount
            If wsopt.Range("C" & x) = "" Then
                If InStr(1, ws.Cells(k, j), wsopt.Range("K" & x)) = 0 Then ws.Cells(k, j) = ws.Cells(k, z) & " " & wsopt.Range("K" & x)
            Else
            Exit For
            End If
            Next x
            End If
        End If
        
        
        If test = True Then Exit For
        End If
        Next j
        End If
    
    If test = True Then
             l = ws.Cells(ws.Rows.Count, j).End(xlUp).Row + 1
        If wsopt.Range("C" & i) = "" Then
            If j = 0 Then wsopt.Range("B" & i) = 1 Else wsopt.Range("B" & i) = j - q
            ws.Cells(l - 1, j + 1) = ws.Cells(l - 1, j + 1) + 1
            wsopt.Range("F" & i) = ws.Cells(l - 1, j + 1)
        Else
            ws.Cells(l, j) = wsopt.Range("C" & i) & wsopt.Range("E" & i)
            ws.Cells(l, j + 1) = ws.Cells(l, j + 1) + 1
            wsopt.Range("F" & i) = 1
        End If
    Else
        k = 1: z = z + 2: q = q + 1
        ws.Cells(k, z) = wsopt.Range("I" & i) & wsopt.Range("J" & i) & wsopt.Range("L" & i) & " " & wsopt.Range("K" & i)
        For x = i + 1 To Rcount
        If wsopt.Range("C" & x) = "" Then
            If InStr(1, ws.Cells(k, z), wsopt.Range("K" & x)) = 0 Then ws.Cells(k, z) = ws.Cells(k, z) & " " & wsopt.Range("K" & x)
        Else
        Exit For
        End If
        Next x
        ws.Cells(k + 1, z) = wsopt.Range("C" & i) & wsopt.Range("E" & i)
        ws.Cells(k + 1, z + 1) = ws.Cells(k, z + 1) + 1
        wsopt.Range("B" & i) = z - q: wsopt.Range("F" & i) = 1
    End If
    End If
Next i
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True

'---> The empty cells in the Exec Time and Spread columns should take on the information'
'of the preceding cell because they are part of the same Spread.'

For i = 12 To Rcount
    If wsopt.Range("E" & i) = "" And i > 12 Then
    wsopt.Range("E" & i) = wsopt.Range("E" & i - 1)
    wsopt.Range("C" & i) = wsopt.Range("C" & i - 1)
    wsopt.Range("C" & i & ":E" & i).Font.Color = -5395027
    End If
Next i

wsopt.Sort.SortFields.Add Key:=Range("C11"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        
         With ActiveSheet.Sort
        .SetRange Range("A12:O" & Rcount)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
For i = 12 To Rcount
     If wsopt.Range("F" & i) = 1 Then
        SpreadNo = SpreadNo + 1: wsopt.Range("D" & i) = SpreadNo
     Else
     wsopt.Range("D" & i) = SpreadNo
     End If
Next i
 
End Sub

Private Sub Sorting()

'--> This Sort macro is preceeded by the above Indexing macro and should sort by the entire position'
'using the date and time of the last Spreads within that position. It is important that each Leg (row)'
'of each Spread stay in order, and each Spread within the Position stay in order.' The most recent'
'Spread will be at the bottom of each Position and the most recent Position, based on the newest
'spread within it, will be listed above other Positions.'

Dim i As Double, Brow As Double, Erow As Double, Prow As Double
Dim Rcount As Double


On Error Resume Next
 Rcount = wsopt.Cells(wsopt.Rows.Count, "B").End(xlUp).Row
 '---> Sorting the output by the Position No.
    wsopt.Sort.SortFields.Clear
    wsopt.Sort.SortFields.Add Key:=Range("B11"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
     
    
    With wsopt.Sort
        .SetRange Range("A11:O" & Rcount)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
'--> Skipping a row between each major position
For i = Rcount To 13 Step -1
If Range("B" & i) <> Range("B" & i - 1) And Range("B" & i) <> "" Then
wsopt.Rows(i & Chr(58) & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next i

'---> Sorting the output by Date descending
 Brow = 0
For i = 12 To Rcount
If wsopt.Range("B" & i) <> "" Then
    If Brow = 0 Then
        Brow = i: Erow = i
        Else
        Erow = i
    End If
Else
    wsopt.Sort.SortFields.Add Key:=Range("C11"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
         With wsopt.Sort
        .SetRange Range("A" & Brow & ":O" & Erow)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Brow = 0
wsopt.Range("A" & i - 1 & ":O" & i - 1).Copy Destination:=wsopt.Range("A" & i & ":O" & i)
wsopt.Range("A" & i & ":O" & i).Font.ThemeColor = xlThemeColorDark1
End If
Next i
wsopt.Range("P" & 12) = wsopt.Range("D" & 12): Prow = wsopt.Range("D" & 12)
For i = 13 To Rcount
If wsopt.Range("B" & i) = wsopt.Range("B" & i - 1) Then
    wsopt.Range("P" & i) = Prow
Else
    Prow = wsopt.Range("D" & i)
    wsopt.Range("P" & i) = Prow
End If
Next i
wsopt.Sort.SortFields.Clear
wsopt.Sort.SortFields.Add Key:=Range("P11"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
     
    
    With wsopt.Sort
        .SetRange Range("A11:P" & Rcount)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
wsopt.Range("B" & 12) = 1: Prow = 1
For i = 13 To Rcount
If wsopt.Range("P" & i) = wsopt.Range("P" & i - 1) Then
    wsopt.Range("B" & i) = Prow
    If wsopt.Range("P" & i) = wsopt.Range("P" & i + 1) Then wsopt.Range("B" & i).Font.Color = -5395027
Else
    Prow = Prow + 1
    wsopt.Range("B" & i) = Prow
End If
Next i
wsopt.Columns("P:P").Delete Shift:=xlToLeft
   
End Sub

Open in new window

rtod2Asked:
Who is Participating?
 
gowflowCommented:
ok here it is. I think it is your Sorting Sub that need some fixing and not the Indexing.
Pls make a new copy of your workbook and delete the present Sorting Sub and replace it by the below code.

PS to delete the sub do this
1) goto VBA and click on the bottom left icon of the code window so you can see 1 sub at a time the default is that you see all sub following each others this is dangerous when deleting code as you may delete part of an other sub. So after clicking on the left icon select from the top right dropdown the Sorting Sub and delete the whole code there.

Paste the below code after any End sub save and exit and try the workbook.
Let me know

What was fixed:
I commented in hte code all that I modified and basically the code was not updating the rowcount when it was inserting blank rows reason why part of the data was correctly sorted but once you hit the original rowcount then the sorting stopped. Also there was an extra sorting that was messing things up so I removed it (comment it out) seems that someoone tried to fix the problem by doing an extra sort !!! and last I added 1 to rowcount to make sure it sorts the last portion !
Enjoy !!

gowflow
Private Sub Sorting()

'--> This Sort macro is preceeded by the above Indexing macro and should sort by the entire position'
'using the date and time of the last Spreads within that position. It is important that each Leg (row)'
'of each Spread stay in order, and each Spread within the Position stay in order.' The most recent'
'Spread will be at the bottom of each Position and the most recent Position, based on the newest
'spread within it, will be listed above other Positions.'

Dim i As Double, Brow As Double, Erow As Double, Prow As Double
Dim Rcount As Double


On Error Resume Next
Rcount = wsopt.Cells(wsopt.Rows.Count, "B").End(xlUp).Row

 
 '---> Sorting the output by the Position No.
    wsopt.Sort.SortFields.Clear
    wsopt.Sort.SortFields.Add Key:=Range("B11"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
     
    
    With wsopt.Sort
        .SetRange Range("A11:O" & Rcount)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
'--> Skipping a row between each major position
For i = Rcount To 13 Step -1
If Range("B" & i) <> Range("B" & i - 1) And Range("B" & i) <> "" Then
wsopt.Rows(i & Chr(58) & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

'added by gowflow to keep correct counting of last row
Rcount = Rcount + 1
End If
Next i

'---> Sorting the output by Date descending
 Brow = 0
'Changed by gowflow from upper Rcount to Rcount +1
For i = 12 To Rcount + 1
If wsopt.Range("B" & i) <> "" Then
    If Brow = 0 Then
        Brow = i: Erow = i
        Else
        Erow = i
    End If
Else
    wsopt.Sort.SortFields.Add Key:=Range("C11"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
         With wsopt.Sort
        .SetRange Range("A" & Brow & ":O" & Erow)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Brow = 0
wsopt.Range("A" & i - 1 & ":O" & i - 1).Copy Destination:=wsopt.Range("A" & i & ":O" & i)
wsopt.Range("A" & i & ":O" & i).Font.ThemeColor = xlThemeColorDark1
End If
Next i

wsopt.Range("P" & 12) = wsopt.Range("D" & 12): Prow = wsopt.Range("D" & 12)
For i = 13 To Rcount
If wsopt.Range("B" & i) = wsopt.Range("B" & i - 1) Then
    wsopt.Range("P" & i) = Prow
Else
    Prow = wsopt.Range("D" & i)
    wsopt.Range("P" & i) = Prow
End If
Next i

'Disabled this section by gowflow as redundant
'wsopt.Sort.SortFields.Clear
'wsopt.Sort.SortFields.Add Key:=Range("P11"), _
'        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
     
    
'    With wsopt.Sort
'        .SetRange Range("A11:P" & Rcount)
'        .Header = xlYes
'        .MatchCase = False
'        .Orientation = xlTopToBottom
'        .SortMethod = xlPinYin
'        .Apply
'    End With
    
wsopt.Range("B" & 12) = 1: Prow = 1
For i = 13 To Rcount
If wsopt.Range("P" & i) = wsopt.Range("P" & i - 1) Then
    wsopt.Range("B" & i) = Prow
    If wsopt.Range("P" & i) = wsopt.Range("P" & i + 1) Then wsopt.Range("B" & i).Font.Color = -5395027
Else
    Prow = Prow + 1
    wsopt.Range("B" & i) = Prow
End If
Next i
wsopt.Columns("P:P").Delete Shift:=xlToLeft
   
End Sub

Open in new window

0
 
rtod2Author Commented:
Outstanding!!

Keep an eye out for new question.
0
 
rtod2Author Commented:
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.