Colorize to match trading platform

Thanks to gowflow and dlmille for such hard work with the included macro and subroutines.  

I now wish to colorize the resulting Output tab after the macro pasted below and included in this workbook processes it to more closely resemble the trading platform itself. This will go a long way toward making the final Output data easier to interpret. A visual screenshot example of two Spreads inside the actual trading platform can be seen here http://screencast.com/t/5qzkBKA9O1Q.  The data below corresponds to the colors picked for Excel to represent dark red and dark green, and have been determined using the color picker in Microsoft Paint.

The header row should be black with white lettering and the spreads and data within them should appear as follows:

Dark Red: R61 / G10 / B10 / #3D0A0A
Dark Green: R10 / G61 / B10 / #0A3D0A

First though, it would be helpful to "undo" the code that is used to gray out items illustrated in this video while leaving the data that is completely whited out alone.

Here is my video attempt http://screencast.com/t/1zeEdNBVm at illustrating the entire coloring requirements including these two rules governing Dark Green and Dark Red.
1. Dark Green if the first Leg of the Spread is a Buy.
2. Dark Red if the first Leg of the Spread is a Sell.

That's it and I am very thankful for your help.

'INTRODUCTION TO MACRO'

'!! Output tabs are created when the macro is run against a selected sheet in the Workbook.'

'1. This macro first looks to see which tab is selected and identifies a data type of rm or pm based'
'solely on the way the data appears within it.

'2. It then copies the data from the Trade History section of the original tab and creates a properly'
'formatted Output tab with a table for the that data where it continues to sort each Spread into'
'meaningful positions.'

'3. It then tries to also copy the notes from the original Order History section into the appropriate'
'cell for each Spread.'

'4. Just like with creating the table, the notes rely heavily on determining whether the originating'
'data type is rm or pm.'

'5. It then cleans the output providing correctly alligned data and returns the focus to A1.

'6. Future development will include making some calculations on each overall position.'

Option Explicit

Const AOH = "Account Order History"
Const ATH = "Account Trade History"
Const PAL = "Profits and Losses"
Const EQT = "Equities"
Const OPT = "Options"
Const OTH = "Others"
Const FRX = "Forex"

Dim wsopt As Worksheet
    

Private Sub AddMOColumn()
'This Sub will Add A new Column before Exp Column J that should indicate either of the following
'M for Monthly when the date in Exp is formated as Mmm-yy the date should be the 3rd friday of the month
'O for Weekly or Quarterly options


Dim MaxRow As Long, I As Long
Dim dDate As Date
Dim ThirdThuOfTheMonth As Date
Dim a

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row
wsopt.Select
Columns("J:J").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("J11") = "OT"

For I = 12 To MaxRow
    If wsopt.Cells(I, "K") <> "" Then
        If wsopt.Cells(I, "K").NumberFormat = "mmm-dd-yy" Then
            wsopt.Cells(I, "J") = "O"
        Else
            wsopt.Cells(I, "J") = "M"
            dDate = wsopt.Cells(I, "K")
            dDate = DateSerial(Year(dDate), Month(dDate), 1)
            Select Case Weekday(dDate)
                Case 5  'If Date is a Thursday then add 14 days
                    ThirdThuOfTheMonth = DateValue(dDate + 14)
                Case Is > 5 'If Date is Friday or saturday then add 21+1 days
                    ThirdThuOfTheMonth = DateValue(dDate + 21 - (Weekday(dDate) - vbThursday))
                Case Is < 5 'If Date is Sunday to Thurthday then add 14+ diffrence to friday days
                    ThirdThuOfTheMonth = DateValue(dDate + 14 + vbThursday - Weekday(dDate))
            End Select
            If Weekday(ThirdThuOfTheMonth) <> vbThursday Then
                MsgBox ("this date: " & ThirdThuOfTheMonth & " does not corespond to a Thursday! on row " & I & " Please check that date in Col K is actually a valid date then re-run the whole macro.")
            End If
            wsopt.Cells(I, "K") = ThirdThuOfTheMonth
        End If
    End If
Next I
End Sub

Private Sub AddDaysandPLColumn()
'This Sub will Add 3 new Columns
'Days to Exp in Col N next to type Column which should be the diffrence in days between Exec Time and Exp
'P/L Balance Col R
'P/L% Col S


Dim MaxRow As Long, I As Long
Dim dDate As Date
Dim ThirdThuOfTheMonth As Date
Dim a

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row
wsopt.Select
Columns("N:N").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("N11") = "Days to Exp"
Columns("R:S").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("R11") = "P/L Balance"
wsopt.Range("S11") = "P/L %"


For I = 12 To MaxRow
    If wsopt.Cells(I, "K") <> "" Then
        wsopt.Cells(I, "N") = DateValue(wsopt.Cells(I, "C")) - DateValue(wsopt.Cells(I, "K"))
    End If
    
    
Next I
End Sub


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
    Dim FirstAddress As String
    
    On Error GoTo Whoa
    
    Application.ScreenUpdating = True
    
    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
        
        If LCase(Left(shName, 2)) = "pm" Then
            '--> Find the "Options" cell in Sheet PM'
            Set bCell = wsPM.Columns(1).Find(what:=OPT, LookIn:=xlFormulas, _
            lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        
            If bCell Is Nothing Then
            '--> Find the "Forex" cell in Sheet PM if Options is not found'
                Set bCell = wsPM.Columns(1).Find(what:=FRX, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
            
            If bCell Is Nothing Then
            '--> Find the "Profits and Losses" cell in Sheet PM if Forex is not found'
                Set bCell = wsPM.Columns(1).Find(what:=PAL, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
        End If
        
        If LCase(Left(shName, 2)) = "rm" Then
            '--> Find the "Equities" cell in Sheet RM'
            Set bCell = wsPM.Columns(1).Find(what:=EQT, LookIn:=xlFormulas, _
            lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
            
            If bCell Is Nothing Then
            '--> Find the "Others" cell in Sheet RM if Equities is not found
                Set bCell = wsPM.Columns(1).Find(what:=OTH, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
        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 LCase(Left(shName, 2)) = "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.
                    wsPM.Range("IV:IV").ClearContents
                    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
                            wsPM.Range("IV" & I).Value = SearchString
                    Next I
                
                    For J = 2 To lastRow
                        MatchString = .Range("D" & J).Value & "###" & _
                                        .Range("F" & J).Value & "###" & _
                                        .Range("G" & J).Value & "###" & _
                                        .Range("H" & J).Value & "###" & _
                                        .Range("I" & J).Value
                
                            Set cCell = wsPM.Range("IV:IV").Find(what:=MatchString, LookIn:=xlFormulas, _
                                        lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                        MatchCase:=False, SearchFormat:=False)
                            If Not cCell Is Nothing Then
                                FirstAddress = cCell.Address
                                    Do
                                        If wsopt.Range("F" & J).Value = wsPM.Range("F" & cCell.Row).Value Then
                                            .Range("A" & J).Value = wsPM.Range("A" & cCell.Row).Value
                                            Exit Do
                                        Else
                                            Set cCell = wsPM.Range("IV:IV").FindNext(cCell)
                                        End If
                                    Loop While Not cCell Is Nothing And cCell.Address <> FirstAddress
                            End If
                    Next J
                End If
                GoTo There

                '--> Copy the notes into the new notes column. old'
                    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
                
There:
                '--> 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
    FixDate
    Indexing
    Sorting
    AddMOColumn
    AddDaysandPLColumn
    If LCase(Left(shName, 2)) = "rm" Then
        UpdateNotes wsPM, AOHRow, ATHRow
    End If
    
    wsopt.Cells(1, 1).Select

    Call cleanOutput
    
    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 cleanOutput()
Dim r As Range, rng As Range
Dim lastRow As Long
Dim cntAddr As String

    'assumes output tab just generated and thus doesn't have total row already, etc., as it had been previously cleared...
    
    'Freeze panes on the first 11 rows so that the header row will always be visible when scrolling.

    ThisWorkbook.Activate 'just in case another workbook is on top

    wsopt.Activate 'just in case another worksheet is in focus
    wsopt.Range("12:12").Select
    ActiveWindow.FreezePanes = False
    ActiveWindow.FreezePanes = True
    
    'Shorten the name of the Order Type column to just Order.
    
    wsopt.Range("Q11").Value = "Order"
    
    'Rename the OT column to say Period and the data in it where M becomes Monthly spelled out, and O becomes Other spelled out.
    
    wsopt.Range("J11").Value = "Period"
    
    lastRow = wsopt.Range("A" & wsopt.Rows.Count).End(xlUp).Row
    Set r = wsopt.Range(wsopt.Range("J12"), wsopt.Cells(lastRow, "J"))
    
    'in case none found, turn on error trap
    On Error Resume Next
    r.Replace what:="M", replacement:="Monthly", lookAt:=xlWhole
    r.Replace what:="O", replacement:="Other", lookAt:=xlWhole
    On Error GoTo 0
    
    'Left justify the data in all columns except for P#, S#, L#, Qty, Strike, Days which should be centered.
    
'MOST DATA CENTERED - However, all the remaining data columns themselves with the exception of Qty should be centered. This will improve readability a great deal. Qty is different though because of the minus (-) sign. My thinking is that it should be right justified with a 2 space offset to give the illusion that it is centered also but still take into account the minus (-) sign in front of some of the numbers.
       
    Set r = wsopt.Range(wsopt.Range("B12"), wsopt.Cells(lastRow, "S"))
    With r
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    
    'now make Notes left justified
    Set r = wsopt.Range("A12:A" & lastRow)
    With r
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
    End With
    
    'and O, P, R & S should be right justified
    Set r = Union(wsopt.Range("O12:O" & lastRow), wsopt.Range("P12:P" & lastRow), wsopt.Range("R12:R" & lastRow), wsopt.Range("S12:S" & lastRow))
    With r
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
    End With
    
    'format Qty so numbers without negatives are one space over
    Set r = wsopt.Range("H12:H" & lastRow)
    r.NumberFormat = "[<0]-0;+0"
    
    Set r = wsopt.Range("N12:N" & lastRow)
    r.NumberFormat = "[<0]0;0"
    
    
    'Add a Total Row at the bottom that simply displays a count for the number notes that are filled in for that column, and leaves every other total empty.
    Call Add_TotalRow_2_ExistingTable
    cntAddr = wsopt.Range(wsopt.Cells(12, 1), wsopt.Cells(lastRow, 1)).Address
    wsopt.Range("A" & lastRow + 1).Formula = "=COUNTA(" & cntAddr & ")"

    
'COMPLETE HEADINGS - Adjust macro to replace column headings in the resulting Output tab for P#, S#, and L# and instead use headings Pos#, Spread# and Leg#.
    wsopt.Range("B11").Value = "Pos#"
    wsopt.Range("D11").Value = "Spread#"
    wsopt.Range("F11").Value = "Leg#"
'HEADER LEFT - A reconsideration of the formatting rules leads me to believe that the header row of the resulting Output tab as well as the data in the Notes column should still be left justified.
    With wsopt.Range("A11:S11")
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
    End With
   
    'Auto-fit all columns to width of data with the exception of the Notes column.
    wsopt.Range("B:S").EntireColumn.AutoFit
        
    'Always return focus to cell A1.
    wsopt.Range("A1").Select
    ActiveWindow.ScrollRow = 1
    ActiveWindow.ScrollColumn = 1

End Sub
Private Sub FixDate()
'This Sub will go thru Exp Column Col J and will Fix the date to allow for either mm-yy or mmm-dd-yy.

Dim MaxRow As Long, I As Long
Dim tmpM As String, tmpD As String, tmpY As String

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row

For I = 12 To MaxRow
    '---> Strip Dates and Fix them
    If wsopt.Cells(I, "J") <> "" Then
        If IsDate(wsopt.Cells(I, "J")) Then
            '---> Format normally if normal Date format as 'mmm-dd-yy'
            wsopt.Cells(I, "J").NumberFormat = "Mmm-yy"
        Else
            '---> Strip the date in Day month Year then re-group so system would recognize
            '     it as a date and then apply format 'mmm-yy'
            tmpM = Left(wsopt.Cells(I, "J"), 3)
            tmpY = Right(wsopt.Cells(I, "J"), 2)
            tmpD = Mid(wsopt.Cells(I, "J"), 4, Len(wsopt.Cells(I, "J")) - 6)
            wsopt.Cells(I, "J") = tmpM & " " & Format(Val(tmpD), "") & ", " & Format(Val(tmpY), "")
            wsopt.Cells(I, "J").NumberFormat = "Mmm-dd-yy"
        End If
    End If

Next I

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
ActiveSheet.PageSetup.PrintArea = ""
wsopt.PageSetup.FitToPagesWide = 1
wsopt.PageSetup.FitToPagesTall = 1

End Sub

'DEFINITIONS - Definitions to understand prior to Indexing and Ordering'
'1. Positions - Positions can be made up of more than one Spread and the newest Positions appear at the top of the sheet.'
'2. Spreads - Spreads can be made up of more than one Leg and their order with a position can change.'
'3. Legs - Legs are made up of individual rows within a Spread and there order within the spread never changes.'

'It is important to note that spreads always belong together in the same position if any of its legs
'contain the same Symbol Exp Strike, and Type of any other spread within the sheet.'

Private Sub Indexing()
'Each Position, Spread, and Leg is indexed with a number according to the value in its Exec Date column.'
'P# - Positions are numbered sequentially with 1 being  meaning that it contains a newer Exec Date than any other positions.'
'S# - Spreads are numbered sequentially with 1 meaning that it contains the a newer Exec Date than the other spreads.'
'L# - 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 alphabetical order.'

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()

'Positions can contain single or multi-legged spreads but the sort order of the legs 'within' each'
'spread never changes. This is an important point because by contrast, the sort order in which each
'spread appears within the overall position does indeed change. Here the oldest spreads should'
'appear at the top of the position while newer spreads should appear at the bottom of the position.'

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 wsopt.Range("B" & I) <> wsopt.Range("B" & I - 1) And wsopt.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
wsopt.Sort.SortFields.Add Key:=wsopt.Range("C11"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

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
        
         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.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

Sub UpdateNotes(WS As Worksheet, FMRow As Long, TORow As Long)
'This Sub will update noted for rm sheets from the Account Order History section in Col A
'To match with data in the Output file created under wsopt variable.

Dim MaxRow As Long, I As Long, J As Long, K As Long, Z As Long
Dim Note As String
Dim NoteItem
Dim Row As Range
Dim Status
Dim ParClose As Long, RowMatched As Long, UnMatchedNotes As Long, NoteFound As Long
Dim BkRatio As Boolean, FoundIT As Boolean
Dim STMonth As Date, ENDMonth As Date


MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row

'---> Clean the Area F to Z to dissec Notes
WS.Range("F" & FMRow & ":ZZ" & TORow).ClearContents
WS.Range("F" & FMRow & ":ZZ" & TORow).ClearFormats


'---> Clean the notes and copy to Col F only for Status Filled Notes
For I = FMRow + 1 To TORow
    Status = Split(WS.Cells(I, "D"), " ")
    For J = 0 To UBound(Status)
        If UCase(Status(J)) = "FILLED" Then
            '---> If a note start with (Replacing ... then remove the first part till the first space
            If Left(WS.Cells(I, "C"), 10) = "(Replacing" Then
                ParClose = InStr(1, WS.Cells(I, "C"), ")")
            Else
                ParClose = 0
            End If
            
            If ParClose <> 0 Then
                WS.Cells(I, "F") = Mid(WS.Cells(I, "C"), ParClose + 2, Len(WS.Cells(I, "C")) - ParClose - 1)
            Else
                WS.Cells(I, "F") = WS.Cells(I, "C")
            End If
            Note = WS.Cells(I, "F")
            NoteItem = Split(Note, " ")
            Z = 0
            
            '---> Check to see if BACKRATIO is found then treat the sequence diffrently
            If InStr(1, WS.Cells(I, "F"), "BACKRATIO") <> 0 Then
                BkRatio = True
            Else
                BkRatio = False
            End If
            
            '---> Loop thru all items in the Note
            For K = 0 To UBound(NoteItem)
                '---> Remove any items that has open/close brakets as this is comment
                If Left(NoteItem(K), 1) = "(" Or Right(NoteItem(K), 1) = ")" Then
                    K = K + 1
                    Z = Z - 1
                End If
                
                '---> Remove any first letter / at first position
                If Left(NoteItem(K), 1) = "/" Then NoteItem(K) = Right(NoteItem(K), Len(NoteItem(K)) - 1)
                
                '---> Keep only VERTICAL/BUTTERFLY/STRANGLE/DIAGONAL in Second position
                If K = 2 Then
                    If UCase(NoteItem(K)) = "VERTICAL" Or _
                       UCase(NoteItem(K)) = "BUTTERFLY" Or _
                       UCase(NoteItem(K)) = "STRANGLE" Or _
                       UCase(NoteItem(K)) = "DIAGONAL" Then
                        Z = 0
                    Else
                        Z = 1
                    End If
                End If
                
                If BkRatio Then
                    '---> If BACKRATIO encountered then treat the sequence diffrently.
                    Select Case K
                    Case 0
                        WS.Cells(I, K + 7).NumberFormat = "@"
                        WS.Cells(I, K + 7) = Format(NoteItem(0), "@")
                    Case 1, 2
                        WS.Cells(I, 7 + 1).NumberFormat = "@"
                        WS.Cells(I, 7 + 1) = Format(NoteItem(1) & " " & NoteItem(2), "@")
                    Case Else
                        WS.Cells(I, K + 7 - 1).NumberFormat = "@"
                        WS.Cells(I, K + 7 - 1) = Format(NoteItem(K), "@")
                    End Select
                Else
                    
                    If InStr(1, Note, "@") <> 0 Then
                        '---> in any sequence is @ is encountered make sure it is positioned
                        '     in Col P as it is the Price Column the rest will follow.
                        If Left(NoteItem(K), 1) = "@" And K + 7 + Z <> 16 Then
                            Z = 16 - 7 - K
                        End If
                    Else
                        If K + 7 + Z = 16 Then
                            Z = 16 - 7 - K + 1
                        End If
                    End If
                    WS.Cells(I, K + 7 + Z).NumberFormat = "@"
                    WS.Cells(I, K + 7 + Z) = Format(NoteItem(K), "@")
                End If
            Next K
        End If
    Next J
Next I


'---> Loop Again thru all the notes in the Account Order History section
'     and match the columns where there is data to find the threads in sheet output
'     Columns in Sheet   G H I J K L M N  O  P  Q
'     Columns in Output  G H E I - [K] L  M  P  Q
'     Column Num Output  7   5 9    11 12 13 16 17
'     Columns to check   Y   Y Y    Y  Y  Y  Y  Y

For I = FMRow + 1 To TORow
    
    If WS.Cells(I, "F") <> "" Then
        wsopt.UsedRange.AutoFilter 1, Criteria1:=""
        If WS.Cells(I, "G") <> "" Then wsopt.UsedRange.AutoFilter 7, WS.Cells(I, "G")
        If WS.Cells(I, "I") <> "" Then wsopt.UsedRange.AutoFilter 5, WS.Cells(I, "I")
        If WS.Cells(I, "J") <> "" Then wsopt.UsedRange.AutoFilter 9, WS.Cells(I, "J")
        If WS.Cells(I, "L") <> "" Then
            If Len(WS.Cells(I, "L")) = 3 Then
                On Error Resume Next
                STMonth = DateSerial(WS.Cells(I, "M"), Month(DateValue(WS.Cells(I, "L") & " 1," & Year(Now))), 1)
                ENDMonth = DateSerial(Year(STMonth), Month(STMonth), Day(Application.WorksheetFunction.EoMonth(STMonth, 0)))
                wsopt.UsedRange.AutoFilter 11, Criteria1:=">=" & STMonth, Operator:=xlAnd, Criteria2:="<=" & ENDMonth
            Else
                On Error Resume Next
                STMonth = DateValue(Left(WS.Cells(I, "L"), 3) & " " & Right(WS.Cells(I, "L"), Len(WS.Cells(I, "L")) - 3) & "," & WS.Cells(I, "M"))
                wsopt.UsedRange.AutoFilter 11, Criteria1:=">=" & STMonth, Operator:=xlAnd, Criteria2:="<=" & STMonth
            End If
        End If
        On Error GoTo 0
        If WS.Cells(I, "N") <> "" And InStr(1, WS.Cells(I, "N"), "/") = 0 Then wsopt.UsedRange.AutoFilter 12, WS.Cells(I, "N")
        If WS.Cells(I, "O") <> "" And InStr(1, WS.Cells(I, "N"), "/") = 0 Then wsopt.UsedRange.AutoFilter 13, WS.Cells(I, "O")
        'If WS.Cells(I, "P") <> "" Then wsopt.UsedRange.AutoFilter 16, Criteria1:="<=" & Val(Right(WS.Cells(I, "P"), Len(WS.Cells(I, "P")) - 1))
        If WS.Cells(I, "Q") <> "" Then wsopt.UsedRange.AutoFilter 17, WS.Cells(I, "Q")
        NoteFound = NoteFound + 1
        FoundIT = True
        
        For Each Row In wsopt.Range("11:" & MaxRow).EntireRow.SpecialCells(xlCellTypeVisible).Rows
            If wsopt.Cells(Row.Row, "A").EntireRow.Hidden = False And wsopt.Cells(Row.Row, "C") <> "" And Row.Row <> 11 Then
                wsopt.Cells(Row.Row, "A") = WS.Cells(I, "F")
                RowMatched = RowMatched + 1
                FoundIT = False
                Exit For
            End If
        Next Row
        
        If FoundIT Then
            'MsgBox (WS.Cells(I, "F") & Chr(10) & "Was not mached in sheet Output !")
            WS.Cells(I, "F").Interior.ColorIndex = 3
            UnMatchedNotes = UnMatchedNotes + 1
        End If
        
        '---> Clear All Filters
        wsopt.UsedRange.AutoFilter 1
        wsopt.UsedRange.AutoFilter 5
        wsopt.UsedRange.AutoFilter 7
        wsopt.UsedRange.AutoFilter 9
        wsopt.UsedRange.AutoFilter 11
        wsopt.UsedRange.AutoFilter 12
        wsopt.UsedRange.AutoFilter 13
        wsopt.UsedRange.AutoFilter 16
        wsopt.UsedRange.AutoFilter 17
    End If
Next I

MsgBox ("A total of " & RowMatched & " Spread items were matched with notes." & Chr(10) _
& "A total of " & NoteFound & " Notes FILLED were found in the Order History Section." & Chr(10) _
& "A total of " & UnMatchedNotes & " Notes were not Matched in Sheet Output.")

End Sub
Private Sub Add_TotalRow_2_ExistingTable()
'Source adapted from:http://vbadud.blogspot.com/2008/07/add-total-row-to-excel-table-using-vba.html
Dim oWS As Worksheet ' Worksheet Object
Dim oRange As Range ' Range Object - Contains Represents the List of Items that need to be made unique
Dim oLst As ListObject ' List Object
Dim oLC As ListColumn ' List Column Object


On Error GoTo Disp_Error

Set oWS = ActiveSheet
If oWS.ListObjects.Count = 0 Then Exit Sub

Set oLst = oWS.ListObjects(1)
oLst.ShowTotals = True

' Change/Set the formatting of the Totals Row
oLst.TotalsRowRange.Font.Bold = True
'oLst.TotalsRowRange.Font.Color = vbRed


If Not oLC Is Nothing Then Set oLC = Nothing
If Not oLst Is Nothing Then Set oLst = Nothing
If Not oWS Is Nothing Then Set oWS = Nothing

' --------------------
' Error Handling
' --------------------
Disp_Error:
If Err <> 0 Then
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, "VBA Tips & Tricks Examples"
Resume Next
End If


End Sub

Open in new window

rtod2Asked:
Who is Participating?
 
dlmilleCommented:
One slight modification - use this one :)

 
'INTRODUCTION TO MACRO'

'!! Output tabs are created when the macro is run against a selected sheet in the Workbook.'

'1. This macro first looks to see which tab is selected and identifies a data type of rm or pm based'
'solely on the way the data appears within it.

'2. It then copies the data from the Trade History section of the original tab and creates a properly'
'formatted Output tab with a table for the that data where it continues to sort each Spread into'
'meaningful positions.'

'3. It then tries to also copy the notes from the original Order History section into the appropriate'
'cell for each Spread.'

'4. Just like with creating the table, the notes rely heavily on determining whether the originating'
'data type is rm or pm.'

'5. It then cleans the output providing correctly alligned data and returns the focus to A1.

'6. Future development will include making some calculations on each overall position.'

Option Explicit

Const AOH = "Account Order History"
Const ATH = "Account Trade History"
Const PAL = "Profits and Losses"
Const EQT = "Equities"
Const OPT = "Options"
Const OTH = "Others"
Const FRX = "Forex"

Dim wsopt As Worksheet
    

Private Sub AddMOColumn()
'This Sub will Add A new Column before Exp Column J that should indicate either of the following
'M for Monthly when the date in Exp is formated as Mmm-yy the date should be the 3rd friday of the month
'O for Weekly or Quarterly options


Dim MaxRow As Long, I As Long
Dim dDate As Date
Dim ThirdThuOfTheMonth As Date
Dim a

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row
wsopt.Select
Columns("J:J").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("J11") = "OT"

For I = 12 To MaxRow
    If wsopt.Cells(I, "K") <> "" Then
        If wsopt.Cells(I, "K").NumberFormat = "mmm-dd-yy" Then
            wsopt.Cells(I, "J") = "O"
        Else
            wsopt.Cells(I, "J") = "M"
            dDate = wsopt.Cells(I, "K")
            dDate = DateSerial(Year(dDate), Month(dDate), 1)
            Select Case Weekday(dDate)
                Case 5  'If Date is a Thursday then add 14 days
                    ThirdThuOfTheMonth = DateValue(dDate + 14)
                Case Is > 5 'If Date is Friday or saturday then add 21+1 days
                    ThirdThuOfTheMonth = DateValue(dDate + 21 - (Weekday(dDate) - vbThursday))
                Case Is < 5 'If Date is Sunday to Thurthday then add 14+ diffrence to friday days
                    ThirdThuOfTheMonth = DateValue(dDate + 14 + vbThursday - Weekday(dDate))
            End Select
            If Weekday(ThirdThuOfTheMonth) <> vbThursday Then
                MsgBox ("this date: " & ThirdThuOfTheMonth & " does not corespond to a Thursday! on row " & I & " Please check that date in Col K is actually a valid date then re-run the whole macro.")
            End If
            wsopt.Cells(I, "K") = ThirdThuOfTheMonth
        End If
    End If
Next I
End Sub

Private Sub AddDaysandPLColumn()
'This Sub will Add 3 new Columns
'Days to Exp in Col N next to type Column which should be the diffrence in days between Exec Time and Exp
'P/L Balance Col R
'P/L% Col S


Dim MaxRow As Long, I As Long
Dim dDate As Date
Dim ThirdThuOfTheMonth As Date
Dim a

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row
wsopt.Select
Columns("N:N").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("N11") = "Days to Exp"
Columns("R:S").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("R11") = "P/L Balance"
wsopt.Range("S11") = "P/L %"


For I = 12 To MaxRow
    If wsopt.Cells(I, "K") <> "" Then
        wsopt.Cells(I, "N") = DateValue(wsopt.Cells(I, "C")) - DateValue(wsopt.Cells(I, "K"))
    End If
    
    
Next I
End Sub


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
    Dim FirstAddress As String
    
    On Error GoTo Whoa
    
    Application.ScreenUpdating = True
    
    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
        
        If LCase(Left(shName, 2)) = "pm" Then
            '--> Find the "Options" cell in Sheet PM'
            Set bCell = wsPM.Columns(1).Find(what:=OPT, LookIn:=xlFormulas, _
            lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        
            If bCell Is Nothing Then
            '--> Find the "Forex" cell in Sheet PM if Options is not found'
                Set bCell = wsPM.Columns(1).Find(what:=FRX, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
            
            If bCell Is Nothing Then
            '--> Find the "Profits and Losses" cell in Sheet PM if Forex is not found'
                Set bCell = wsPM.Columns(1).Find(what:=PAL, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
        End If
        
        If LCase(Left(shName, 2)) = "rm" Then
            '--> Find the "Equities" cell in Sheet RM'
            Set bCell = wsPM.Columns(1).Find(what:=EQT, LookIn:=xlFormulas, _
            lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
            
            If bCell Is Nothing Then
            '--> Find the "Others" cell in Sheet RM if Equities is not found
                Set bCell = wsPM.Columns(1).Find(what:=OTH, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
        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 LCase(Left(shName, 2)) = "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.
                    wsPM.Range("IV:IV").ClearContents
                    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
                            wsPM.Range("IV" & I).Value = SearchString
                    Next I
                
                    For J = 2 To lastRow
                        MatchString = .Range("D" & J).Value & "###" & _
                                        .Range("F" & J).Value & "###" & _
                                        .Range("G" & J).Value & "###" & _
                                        .Range("H" & J).Value & "###" & _
                                        .Range("I" & J).Value
                
                            Set cCell = wsPM.Range("IV:IV").Find(what:=MatchString, LookIn:=xlFormulas, _
                                        lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                        MatchCase:=False, SearchFormat:=False)
                            If Not cCell Is Nothing Then
                                FirstAddress = cCell.Address
                                    Do
                                        If wsopt.Range("F" & J).Value = wsPM.Range("F" & cCell.Row).Value Then
                                            .Range("A" & J).Value = wsPM.Range("A" & cCell.Row).Value
                                            Exit Do
                                        Else
                                            Set cCell = wsPM.Range("IV:IV").FindNext(cCell)
                                        End If
                                    Loop While Not cCell Is Nothing And cCell.Address <> FirstAddress
                            End If
                    Next J
                End If
                GoTo There

                '--> Copy the notes into the new notes column. old'
                    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
                
There:
                '--> 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
    FixDate
    Indexing
    Sorting
    AddMOColumn
    AddDaysandPLColumn
    If LCase(Left(shName, 2)) = "rm" Then
        UpdateNotes wsPM, AOHRow, ATHRow
    End If
    
    wsopt.Cells(1, 1).Select

    Call cleanOutput
    
    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 FixDate()
'This Sub will go thru Exp Column Col J and will Fix the date to allow for either mm-yy or mmm-dd-yy.

Dim MaxRow As Long, I As Long
Dim tmpM As String, tmpD As String, tmpY As String

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row

For I = 12 To MaxRow
    '---> Strip Dates and Fix them
    If wsopt.Cells(I, "J") <> "" Then
        If IsDate(wsopt.Cells(I, "J")) Then
            '---> Format normally if normal Date format as 'mmm-dd-yy'
            wsopt.Cells(I, "J").NumberFormat = "Mmm-yy"
        Else
            '---> Strip the date in Day month Year then re-group so system would recognize
            '     it as a date and then apply format 'mmm-yy'
            tmpM = Left(wsopt.Cells(I, "J"), 3)
            tmpY = Right(wsopt.Cells(I, "J"), 2)
            tmpD = Mid(wsopt.Cells(I, "J"), 4, Len(wsopt.Cells(I, "J")) - 6)
            wsopt.Cells(I, "J") = tmpM & " " & Format(Val(tmpD), "") & ", " & Format(Val(tmpY), "")
            wsopt.Cells(I, "J").NumberFormat = "Mmm-dd-yy"
        End If
    End If

Next I

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
ActiveSheet.PageSetup.PrintArea = ""
wsopt.PageSetup.FitToPagesWide = 1
wsopt.PageSetup.FitToPagesTall = 1

End Sub

'DEFINITIONS - Definitions to understand prior to Indexing and Ordering'
'1. Positions - Positions can be made up of more than one Spread and the newest Positions appear at the top of the sheet.'
'2. Spreads - Spreads can be made up of more than one Leg and their order with a position can change.'
'3. Legs - Legs are made up of individual rows within a Spread and there order within the spread never changes.'

'It is important to note that spreads always belong together in the same position if any of its legs
'contain the same Symbol Exp Strike, and Type of any other spread within the sheet.'

Private Sub Indexing()
'Each Position, Spread, and Leg is indexed with a number according to the value in its Exec Date column.'
'P# - Positions are numbered sequentially with 1 being  meaning that it contains a newer Exec Date than any other positions.'
'S# - Spreads are numbered sequentially with 1 meaning that it contains the a newer Exec Date than the other spreads.'
'L# - 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 alphabetical order.'

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)
    'dlmille no grey - 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()

'Positions can contain single or multi-legged spreads but the sort order of the legs 'within' each'
'spread never changes. This is an important point because by contrast, the sort order in which each
'spread appears within the overall position does indeed change. Here the oldest spreads should'
'appear at the top of the position while newer spreads should appear at the bottom of the position.'

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 wsopt.Range("B" & I) <> wsopt.Range("B" & I - 1) And wsopt.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
wsopt.Sort.SortFields.Add Key:=wsopt.Range("C11"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

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
        
         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.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
    'dlmille no grey - 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

Sub UpdateNotes(WS As Worksheet, FMRow As Long, TORow As Long)
'This Sub will update noted for rm sheets from the Account Order History section in Col A
'To match with data in the Output file created under wsopt variable.

Dim MaxRow As Long, I As Long, J As Long, K As Long, Z As Long
Dim Note As String
Dim NoteItem
Dim Row As Range
Dim Status
Dim ParClose As Long, RowMatched As Long, UnMatchedNotes As Long, NoteFound As Long
Dim BkRatio As Boolean, FoundIT As Boolean
Dim STMonth As Date, ENDMonth As Date


MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row

'---> Clean the Area F to Z to dissec Notes
WS.Range("F" & FMRow & ":ZZ" & TORow).ClearContents
WS.Range("F" & FMRow & ":ZZ" & TORow).ClearFormats


'---> Clean the notes and copy to Col F only for Status Filled Notes
For I = FMRow + 1 To TORow
    Status = Split(WS.Cells(I, "D"), " ")
    For J = 0 To UBound(Status)
        If UCase(Status(J)) = "FILLED" Then
            '---> If a note start with (Replacing ... then remove the first part till the first space
            If Left(WS.Cells(I, "C"), 10) = "(Replacing" Then
                ParClose = InStr(1, WS.Cells(I, "C"), ")")
            Else
                ParClose = 0
            End If
            
            If ParClose <> 0 Then
                WS.Cells(I, "F") = Mid(WS.Cells(I, "C"), ParClose + 2, Len(WS.Cells(I, "C")) - ParClose - 1)
            Else
                WS.Cells(I, "F") = WS.Cells(I, "C")
            End If
            Note = WS.Cells(I, "F")
            NoteItem = Split(Note, " ")
            Z = 0
            
            '---> Check to see if BACKRATIO is found then treat the sequence diffrently
            If InStr(1, WS.Cells(I, "F"), "BACKRATIO") <> 0 Then
                BkRatio = True
            Else
                BkRatio = False
            End If
            
            '---> Loop thru all items in the Note
            For K = 0 To UBound(NoteItem)
                '---> Remove any items that has open/close brakets as this is comment
                If Left(NoteItem(K), 1) = "(" Or Right(NoteItem(K), 1) = ")" Then
                    K = K + 1
                    Z = Z - 1
                End If
                
                '---> Remove any first letter / at first position
                If Left(NoteItem(K), 1) = "/" Then NoteItem(K) = Right(NoteItem(K), Len(NoteItem(K)) - 1)
                
                '---> Keep only VERTICAL/BUTTERFLY/STRANGLE/DIAGONAL in Second position
                If K = 2 Then
                    If UCase(NoteItem(K)) = "VERTICAL" Or _
                       UCase(NoteItem(K)) = "BUTTERFLY" Or _
                       UCase(NoteItem(K)) = "STRANGLE" Or _
                       UCase(NoteItem(K)) = "DIAGONAL" Then
                        Z = 0
                    Else
                        Z = 1
                    End If
                End If
                
                If BkRatio Then
                    '---> If BACKRATIO encountered then treat the sequence diffrently.
                    Select Case K
                    Case 0
                        WS.Cells(I, K + 7).NumberFormat = "@"
                        WS.Cells(I, K + 7) = Format(NoteItem(0), "@")
                    Case 1, 2
                        WS.Cells(I, 7 + 1).NumberFormat = "@"
                        WS.Cells(I, 7 + 1) = Format(NoteItem(1) & " " & NoteItem(2), "@")
                    Case Else
                        WS.Cells(I, K + 7 - 1).NumberFormat = "@"
                        WS.Cells(I, K + 7 - 1) = Format(NoteItem(K), "@")
                    End Select
                Else
                    
                    If InStr(1, Note, "@") <> 0 Then
                        '---> in any sequence is @ is encountered make sure it is positioned
                        '     in Col P as it is the Price Column the rest will follow.
                        If Left(NoteItem(K), 1) = "@" And K + 7 + Z <> 16 Then
                            Z = 16 - 7 - K
                        End If
                    Else
                        If K + 7 + Z = 16 Then
                            Z = 16 - 7 - K + 1
                        End If
                    End If
                    WS.Cells(I, K + 7 + Z).NumberFormat = "@"
                    WS.Cells(I, K + 7 + Z) = Format(NoteItem(K), "@")
                End If
            Next K
        End If
    Next J
Next I


'---> Loop Again thru all the notes in the Account Order History section
'     and match the columns where there is data to find the threads in sheet output
'     Columns in Sheet   G H I J K L M N  O  P  Q
'     Columns in Output  G H E I - [K] L  M  P  Q
'     Column Num Output  7   5 9    11 12 13 16 17
'     Columns to check   Y   Y Y    Y  Y  Y  Y  Y

For I = FMRow + 1 To TORow
    
    If WS.Cells(I, "F") <> "" Then
        wsopt.UsedRange.AutoFilter 1, Criteria1:=""
        If WS.Cells(I, "G") <> "" Then wsopt.UsedRange.AutoFilter 7, WS.Cells(I, "G")
        If WS.Cells(I, "I") <> "" Then wsopt.UsedRange.AutoFilter 5, WS.Cells(I, "I")
        If WS.Cells(I, "J") <> "" Then wsopt.UsedRange.AutoFilter 9, WS.Cells(I, "J")
        If WS.Cells(I, "L") <> "" Then
            If Len(WS.Cells(I, "L")) = 3 Then
                On Error Resume Next
                STMonth = DateSerial(WS.Cells(I, "M"), Month(DateValue(WS.Cells(I, "L") & " 1," & Year(Now))), 1)
                ENDMonth = DateSerial(Year(STMonth), Month(STMonth), Day(Application.WorksheetFunction.EoMonth(STMonth, 0)))
                wsopt.UsedRange.AutoFilter 11, Criteria1:=">=" & STMonth, Operator:=xlAnd, Criteria2:="<=" & ENDMonth
            Else
                On Error Resume Next
                STMonth = DateValue(Left(WS.Cells(I, "L"), 3) & " " & Right(WS.Cells(I, "L"), Len(WS.Cells(I, "L")) - 3) & "," & WS.Cells(I, "M"))
                wsopt.UsedRange.AutoFilter 11, Criteria1:=">=" & STMonth, Operator:=xlAnd, Criteria2:="<=" & STMonth
            End If
        End If
        On Error GoTo 0
        If WS.Cells(I, "N") <> "" And InStr(1, WS.Cells(I, "N"), "/") = 0 Then wsopt.UsedRange.AutoFilter 12, WS.Cells(I, "N")
        If WS.Cells(I, "O") <> "" And InStr(1, WS.Cells(I, "N"), "/") = 0 Then wsopt.UsedRange.AutoFilter 13, WS.Cells(I, "O")
        'If WS.Cells(I, "P") <> "" Then wsopt.UsedRange.AutoFilter 16, Criteria1:="<=" & Val(Right(WS.Cells(I, "P"), Len(WS.Cells(I, "P")) - 1))
        If WS.Cells(I, "Q") <> "" Then wsopt.UsedRange.AutoFilter 17, WS.Cells(I, "Q")
        NoteFound = NoteFound + 1
        FoundIT = True
        
        For Each Row In wsopt.Range("11:" & MaxRow).EntireRow.SpecialCells(xlCellTypeVisible).Rows
            If wsopt.Cells(Row.Row, "A").EntireRow.Hidden = False And wsopt.Cells(Row.Row, "C") <> "" And Row.Row <> 11 Then
                wsopt.Cells(Row.Row, "A") = WS.Cells(I, "F")
                RowMatched = RowMatched + 1
                FoundIT = False
                Exit For
            End If
        Next Row
        
        If FoundIT Then
            'MsgBox (WS.Cells(I, "F") & Chr(10) & "Was not mached in sheet Output !")
            WS.Cells(I, "F").Interior.ColorIndex = 3
            UnMatchedNotes = UnMatchedNotes + 1
        End If
        
        '---> Clear All Filters
        wsopt.UsedRange.AutoFilter 1
        wsopt.UsedRange.AutoFilter 5
        wsopt.UsedRange.AutoFilter 7
        wsopt.UsedRange.AutoFilter 9
        wsopt.UsedRange.AutoFilter 11
        wsopt.UsedRange.AutoFilter 12
        wsopt.UsedRange.AutoFilter 13
        wsopt.UsedRange.AutoFilter 16
        wsopt.UsedRange.AutoFilter 17
    End If
Next I

MsgBox ("A total of " & RowMatched & " Spread items were matched with notes." & Chr(10) _
& "A total of " & NoteFound & " Notes FILLED were found in the Order History Section." & Chr(10) _
& "A total of " & UnMatchedNotes & " Notes were not Matched in Sheet Output.")

End Sub
Private Sub cleanOutput()
Dim r As Range, rng As Range
Dim lastRow As Long
Dim cntAddr As String

    'assumes output tab just generated and thus doesn't have total row already, etc., as it had been previously cleared...
    
    'Freeze panes on the first 11 rows so that the header row will always be visible when scrolling.

    ThisWorkbook.Activate 'just in case another workbook is on top

    wsopt.Activate 'just in case another worksheet is in focus
    wsopt.Range("12:12").Select
    ActiveWindow.FreezePanes = False
    ActiveWindow.FreezePanes = True
    
    'Shorten the name of the Order Type column to just Order.
    
    wsopt.Range("Q11").Value = "Order"
    
    'Rename the OT column to say Period and the data in it where M becomes Monthly spelled out, and O becomes Other spelled out.
    
    wsopt.Range("J11").Value = "Period"
    
    lastRow = wsopt.Range("A" & wsopt.Rows.Count).End(xlUp).Row
    Set r = wsopt.Range(wsopt.Range("J12"), wsopt.Cells(lastRow, "J"))
    
    'in case none found, turn on error trap
    On Error Resume Next
    r.Replace what:="M", replacement:="Monthly", lookAt:=xlWhole
    r.Replace what:="O", replacement:="Other", lookAt:=xlWhole
    On Error GoTo 0
    
    'Left justify the data in all columns except for P#, S#, L#, Qty, Strike, Days which should be centered.
    
'MOST DATA CENTERED - However, all the remaining data columns themselves with the exception of Qty should be centered. This will improve readability a great deal. Qty is different though because of the minus (-) sign. My thinking is that it should be right justified with a 2 space offset to give the illusion that it is centered also but still take into account the minus (-) sign in front of some of the numbers.
       
    Set r = wsopt.Range(wsopt.Range("B12"), wsopt.Cells(lastRow, "S"))
    With r
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    
    'now make Notes left justified
    Set r = wsopt.Range("A12:A" & lastRow)
    With r
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
    End With
    
    'and O, P, R & S should be right justified
    Set r = Union(wsopt.Range("O12:O" & lastRow), wsopt.Range("P12:P" & lastRow), wsopt.Range("R12:R" & lastRow), wsopt.Range("S12:S" & lastRow))
    With r
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
    End With
    
    'format Qty so numbers without negatives are one space over
    Set r = wsopt.Range("H12:H" & lastRow)
    r.NumberFormat = "[<0]-0;+0"
    
    Set r = wsopt.Range("N12:N" & lastRow)
    r.NumberFormat = "[<0]0;0"
    
    
    'Add a Total Row at the bottom that simply displays a count for the number notes that are filled in for that column, and leaves every other total empty.
    Call Add_TotalRow_2_ExistingTable
    cntAddr = wsopt.Range(wsopt.Cells(12, 1), wsopt.Cells(lastRow, 1)).Address
    wsopt.Range("A" & lastRow + 1).Formula = "=COUNTA(" & cntAddr & ")"

    
'COMPLETE HEADINGS - Adjust macro to replace column headings in the resulting Output tab for P#, S#, and L# and instead use headings Pos#, Spread# and Leg#.
    wsopt.Range("B11").Value = "Pos#"
    wsopt.Range("D11").Value = "Spread#"
    wsopt.Range("F11").Value = "Leg#"
'HEADER LEFT - A reconsideration of the formatting rules leads me to believe that the header row of the resulting Output tab as well as the data in the Notes column should still be left justified.
    With wsopt.Range("A11:S11")
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
    End With
   
    'Auto-fit all columns to width of data with the exception of the Notes column.
    wsopt.Range("B:S").EntireColumn.AutoFit
        
    'fix header row
    With Range("A11:S11").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
    Call highlightSpreads(lastRow)
    
    'Always return focus to cell A1.
    wsopt.Range("A1").Select
    ActiveWindow.ScrollRow = 1
    ActiveWindow.ScrollColumn = 1

End Sub
Sub highlightSpreads(lastRow As Long)
Dim r As Range
Dim rng As Range
Dim lastSpread As Long
Dim topSpread As Range
Dim botSpread As Range
Dim rSpread As Range
'Dark Red: R61 / G10 / B10 / #3D0A0A
'Dark Green: R10 / G61 / B10 / #0A3D0A

    Set rng = wsopt.Range("D12:D" & lastRow + 1)
    
    lastSpread = rng.Cells(1, 1).Value
    Set topSpread = rng.Cells(1, 1)
    Set botSpread = rng.Cells(1, 1)
    
    For Each r In rng
        If r.Font.Color <> vbWhite Then
            If r.Value = lastSpread Then
                Set botSpread = r
            Else
                'highlight spread
                Set rSpread = wsopt.Range(wsopt.Cells(topSpread.Row, "A"), wsopt.Cells(botSpread.Row, "S"))
                If topSpread.Offset(, 3).Value = "BUY" Then
                    rSpread.Interior.Color = RGB(10, 61, 10) 'vbGreen
                    rSpread.Font.Color = RGB(255, 220, 0)
                Else
                    rSpread.Interior.Color = RGB(61, 10, 10) 'vbRed
                    rSpread.Font.Color = RGB(255, 220, 10)
                End If

                lastSpread = r.Value
                Set topSpread = r
                Set botSpread = r
            End If
        End If
    Next r
    
End Sub
Private Sub Add_TotalRow_2_ExistingTable()
'Source adapted from:http://vbadud.blogspot.com/2008/07/add-total-row-to-excel-table-using-vba.html
Dim oWS As Worksheet ' Worksheet Object
Dim oRange As Range ' Range Object - Contains Represents the List of Items that need to be made unique
Dim oLst As ListObject ' List Object
Dim oLC As ListColumn ' List Column Object


On Error GoTo Disp_Error

Set oWS = ActiveSheet
If oWS.ListObjects.Count = 0 Then Exit Sub

Set oLst = oWS.ListObjects(1)
oLst.ShowTotals = True

' Change/Set the formatting of the Totals Row
oLst.TotalsRowRange.Font.Bold = True
'oLst.TotalsRowRange.Font.Color = vbRed


If Not oLC Is Nothing Then Set oLC = Nothing
If Not oLst Is Nothing Then Set oLst = Nothing
If Not oWS Is Nothing Then Set oWS = Nothing

' --------------------
' Error Handling
' --------------------
Disp_Error:
If Err <> 0 Then
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, "VBA Tips & Tricks Examples"
Resume Next
End If


End Sub

Open in new window


Dave
0
 
dlmilleCommented:
Ok.  I'm working on the font color for spreads,but the rest is here:
 
'INTRODUCTION TO MACRO'

'!! Output tabs are created when the macro is run against a selected sheet in the Workbook.'

'1. This macro first looks to see which tab is selected and identifies a data type of rm or pm based'
'solely on the way the data appears within it.

'2. It then copies the data from the Trade History section of the original tab and creates a properly'
'formatted Output tab with a table for the that data where it continues to sort each Spread into'
'meaningful positions.'

'3. It then tries to also copy the notes from the original Order History section into the appropriate'
'cell for each Spread.'

'4. Just like with creating the table, the notes rely heavily on determining whether the originating'
'data type is rm or pm.'

'5. It then cleans the output providing correctly alligned data and returns the focus to A1.

'6. Future development will include making some calculations on each overall position.'

Option Explicit

Const AOH = "Account Order History"
Const ATH = "Account Trade History"
Const PAL = "Profits and Losses"
Const EQT = "Equities"
Const OPT = "Options"
Const OTH = "Others"
Const FRX = "Forex"

Dim wsopt As Worksheet
    

Private Sub AddMOColumn()
'This Sub will Add A new Column before Exp Column J that should indicate either of the following
'M for Monthly when the date in Exp is formated as Mmm-yy the date should be the 3rd friday of the month
'O for Weekly or Quarterly options


Dim MaxRow As Long, I As Long
Dim dDate As Date
Dim ThirdThuOfTheMonth As Date
Dim a

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row
wsopt.Select
Columns("J:J").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("J11") = "OT"

For I = 12 To MaxRow
    If wsopt.Cells(I, "K") <> "" Then
        If wsopt.Cells(I, "K").NumberFormat = "mmm-dd-yy" Then
            wsopt.Cells(I, "J") = "O"
        Else
            wsopt.Cells(I, "J") = "M"
            dDate = wsopt.Cells(I, "K")
            dDate = DateSerial(Year(dDate), Month(dDate), 1)
            Select Case Weekday(dDate)
                Case 5  'If Date is a Thursday then add 14 days
                    ThirdThuOfTheMonth = DateValue(dDate + 14)
                Case Is > 5 'If Date is Friday or saturday then add 21+1 days
                    ThirdThuOfTheMonth = DateValue(dDate + 21 - (Weekday(dDate) - vbThursday))
                Case Is < 5 'If Date is Sunday to Thurthday then add 14+ diffrence to friday days
                    ThirdThuOfTheMonth = DateValue(dDate + 14 + vbThursday - Weekday(dDate))
            End Select
            If Weekday(ThirdThuOfTheMonth) <> vbThursday Then
                MsgBox ("this date: " & ThirdThuOfTheMonth & " does not corespond to a Thursday! on row " & I & " Please check that date in Col K is actually a valid date then re-run the whole macro.")
            End If
            wsopt.Cells(I, "K") = ThirdThuOfTheMonth
        End If
    End If
Next I
End Sub

Private Sub AddDaysandPLColumn()
'This Sub will Add 3 new Columns
'Days to Exp in Col N next to type Column which should be the diffrence in days between Exec Time and Exp
'P/L Balance Col R
'P/L% Col S


Dim MaxRow As Long, I As Long
Dim dDate As Date
Dim ThirdThuOfTheMonth As Date
Dim a

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row
wsopt.Select
Columns("N:N").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("N11") = "Days to Exp"
Columns("R:S").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("R11") = "P/L Balance"
wsopt.Range("S11") = "P/L %"


For I = 12 To MaxRow
    If wsopt.Cells(I, "K") <> "" Then
        wsopt.Cells(I, "N") = DateValue(wsopt.Cells(I, "C")) - DateValue(wsopt.Cells(I, "K"))
    End If
    
    
Next I
End Sub


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
    Dim FirstAddress As String
    
    On Error GoTo Whoa
    
    Application.ScreenUpdating = True
    
    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
        
        If LCase(Left(shName, 2)) = "pm" Then
            '--> Find the "Options" cell in Sheet PM'
            Set bCell = wsPM.Columns(1).Find(what:=OPT, LookIn:=xlFormulas, _
            lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        
            If bCell Is Nothing Then
            '--> Find the "Forex" cell in Sheet PM if Options is not found'
                Set bCell = wsPM.Columns(1).Find(what:=FRX, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
            
            If bCell Is Nothing Then
            '--> Find the "Profits and Losses" cell in Sheet PM if Forex is not found'
                Set bCell = wsPM.Columns(1).Find(what:=PAL, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
        End If
        
        If LCase(Left(shName, 2)) = "rm" Then
            '--> Find the "Equities" cell in Sheet RM'
            Set bCell = wsPM.Columns(1).Find(what:=EQT, LookIn:=xlFormulas, _
            lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
            
            If bCell Is Nothing Then
            '--> Find the "Others" cell in Sheet RM if Equities is not found
                Set bCell = wsPM.Columns(1).Find(what:=OTH, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
        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 LCase(Left(shName, 2)) = "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.
                    wsPM.Range("IV:IV").ClearContents
                    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
                            wsPM.Range("IV" & I).Value = SearchString
                    Next I
                
                    For J = 2 To lastRow
                        MatchString = .Range("D" & J).Value & "###" & _
                                        .Range("F" & J).Value & "###" & _
                                        .Range("G" & J).Value & "###" & _
                                        .Range("H" & J).Value & "###" & _
                                        .Range("I" & J).Value
                
                            Set cCell = wsPM.Range("IV:IV").Find(what:=MatchString, LookIn:=xlFormulas, _
                                        lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                        MatchCase:=False, SearchFormat:=False)
                            If Not cCell Is Nothing Then
                                FirstAddress = cCell.Address
                                    Do
                                        If wsopt.Range("F" & J).Value = wsPM.Range("F" & cCell.Row).Value Then
                                            .Range("A" & J).Value = wsPM.Range("A" & cCell.Row).Value
                                            Exit Do
                                        Else
                                            Set cCell = wsPM.Range("IV:IV").FindNext(cCell)
                                        End If
                                    Loop While Not cCell Is Nothing And cCell.Address <> FirstAddress
                            End If
                    Next J
                End If
                GoTo There

                '--> Copy the notes into the new notes column. old'
                    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
                
There:
                '--> 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
    FixDate
    Indexing
    Sorting
    AddMOColumn
    AddDaysandPLColumn
    If LCase(Left(shName, 2)) = "rm" Then
        UpdateNotes wsPM, AOHRow, ATHRow
    End If
    
    wsopt.Cells(1, 1).Select

    Call cleanOutput
    
    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 FixDate()
'This Sub will go thru Exp Column Col J and will Fix the date to allow for either mm-yy or mmm-dd-yy.

Dim MaxRow As Long, I As Long
Dim tmpM As String, tmpD As String, tmpY As String

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row

For I = 12 To MaxRow
    '---> Strip Dates and Fix them
    If wsopt.Cells(I, "J") <> "" Then
        If IsDate(wsopt.Cells(I, "J")) Then
            '---> Format normally if normal Date format as 'mmm-dd-yy'
            wsopt.Cells(I, "J").NumberFormat = "Mmm-yy"
        Else
            '---> Strip the date in Day month Year then re-group so system would recognize
            '     it as a date and then apply format 'mmm-yy'
            tmpM = Left(wsopt.Cells(I, "J"), 3)
            tmpY = Right(wsopt.Cells(I, "J"), 2)
            tmpD = Mid(wsopt.Cells(I, "J"), 4, Len(wsopt.Cells(I, "J")) - 6)
            wsopt.Cells(I, "J") = tmpM & " " & Format(Val(tmpD), "") & ", " & Format(Val(tmpY), "")
            wsopt.Cells(I, "J").NumberFormat = "Mmm-dd-yy"
        End If
    End If

Next I

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
ActiveSheet.PageSetup.PrintArea = ""
wsopt.PageSetup.FitToPagesWide = 1
wsopt.PageSetup.FitToPagesTall = 1

End Sub

'DEFINITIONS - Definitions to understand prior to Indexing and Ordering'
'1. Positions - Positions can be made up of more than one Spread and the newest Positions appear at the top of the sheet.'
'2. Spreads - Spreads can be made up of more than one Leg and their order with a position can change.'
'3. Legs - Legs are made up of individual rows within a Spread and there order within the spread never changes.'

'It is important to note that spreads always belong together in the same position if any of its legs
'contain the same Symbol Exp Strike, and Type of any other spread within the sheet.'

Private Sub Indexing()
'Each Position, Spread, and Leg is indexed with a number according to the value in its Exec Date column.'
'P# - Positions are numbered sequentially with 1 being  meaning that it contains a newer Exec Date than any other positions.'
'S# - Spreads are numbered sequentially with 1 meaning that it contains the a newer Exec Date than the other spreads.'
'L# - 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 alphabetical order.'

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)
    'dlmille no grey - 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()

'Positions can contain single or multi-legged spreads but the sort order of the legs 'within' each'
'spread never changes. This is an important point because by contrast, the sort order in which each
'spread appears within the overall position does indeed change. Here the oldest spreads should'
'appear at the top of the position while newer spreads should appear at the bottom of the position.'

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 wsopt.Range("B" & I) <> wsopt.Range("B" & I - 1) And wsopt.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
wsopt.Sort.SortFields.Add Key:=wsopt.Range("C11"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

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
        
         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.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
    'dlmille no grey - 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

Sub UpdateNotes(WS As Worksheet, FMRow As Long, TORow As Long)
'This Sub will update noted for rm sheets from the Account Order History section in Col A
'To match with data in the Output file created under wsopt variable.

Dim MaxRow As Long, I As Long, J As Long, K As Long, Z As Long
Dim Note As String
Dim NoteItem
Dim Row As Range
Dim Status
Dim ParClose As Long, RowMatched As Long, UnMatchedNotes As Long, NoteFound As Long
Dim BkRatio As Boolean, FoundIT As Boolean
Dim STMonth As Date, ENDMonth As Date


MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row

'---> Clean the Area F to Z to dissec Notes
WS.Range("F" & FMRow & ":ZZ" & TORow).ClearContents
WS.Range("F" & FMRow & ":ZZ" & TORow).ClearFormats


'---> Clean the notes and copy to Col F only for Status Filled Notes
For I = FMRow + 1 To TORow
    Status = Split(WS.Cells(I, "D"), " ")
    For J = 0 To UBound(Status)
        If UCase(Status(J)) = "FILLED" Then
            '---> If a note start with (Replacing ... then remove the first part till the first space
            If Left(WS.Cells(I, "C"), 10) = "(Replacing" Then
                ParClose = InStr(1, WS.Cells(I, "C"), ")")
            Else
                ParClose = 0
            End If
            
            If ParClose <> 0 Then
                WS.Cells(I, "F") = Mid(WS.Cells(I, "C"), ParClose + 2, Len(WS.Cells(I, "C")) - ParClose - 1)
            Else
                WS.Cells(I, "F") = WS.Cells(I, "C")
            End If
            Note = WS.Cells(I, "F")
            NoteItem = Split(Note, " ")
            Z = 0
            
            '---> Check to see if BACKRATIO is found then treat the sequence diffrently
            If InStr(1, WS.Cells(I, "F"), "BACKRATIO") <> 0 Then
                BkRatio = True
            Else
                BkRatio = False
            End If
            
            '---> Loop thru all items in the Note
            For K = 0 To UBound(NoteItem)
                '---> Remove any items that has open/close brakets as this is comment
                If Left(NoteItem(K), 1) = "(" Or Right(NoteItem(K), 1) = ")" Then
                    K = K + 1
                    Z = Z - 1
                End If
                
                '---> Remove any first letter / at first position
                If Left(NoteItem(K), 1) = "/" Then NoteItem(K) = Right(NoteItem(K), Len(NoteItem(K)) - 1)
                
                '---> Keep only VERTICAL/BUTTERFLY/STRANGLE/DIAGONAL in Second position
                If K = 2 Then
                    If UCase(NoteItem(K)) = "VERTICAL" Or _
                       UCase(NoteItem(K)) = "BUTTERFLY" Or _
                       UCase(NoteItem(K)) = "STRANGLE" Or _
                       UCase(NoteItem(K)) = "DIAGONAL" Then
                        Z = 0
                    Else
                        Z = 1
                    End If
                End If
                
                If BkRatio Then
                    '---> If BACKRATIO encountered then treat the sequence diffrently.
                    Select Case K
                    Case 0
                        WS.Cells(I, K + 7).NumberFormat = "@"
                        WS.Cells(I, K + 7) = Format(NoteItem(0), "@")
                    Case 1, 2
                        WS.Cells(I, 7 + 1).NumberFormat = "@"
                        WS.Cells(I, 7 + 1) = Format(NoteItem(1) & " " & NoteItem(2), "@")
                    Case Else
                        WS.Cells(I, K + 7 - 1).NumberFormat = "@"
                        WS.Cells(I, K + 7 - 1) = Format(NoteItem(K), "@")
                    End Select
                Else
                    
                    If InStr(1, Note, "@") <> 0 Then
                        '---> in any sequence is @ is encountered make sure it is positioned
                        '     in Col P as it is the Price Column the rest will follow.
                        If Left(NoteItem(K), 1) = "@" And K + 7 + Z <> 16 Then
                            Z = 16 - 7 - K
                        End If
                    Else
                        If K + 7 + Z = 16 Then
                            Z = 16 - 7 - K + 1
                        End If
                    End If
                    WS.Cells(I, K + 7 + Z).NumberFormat = "@"
                    WS.Cells(I, K + 7 + Z) = Format(NoteItem(K), "@")
                End If
            Next K
        End If
    Next J
Next I


'---> Loop Again thru all the notes in the Account Order History section
'     and match the columns where there is data to find the threads in sheet output
'     Columns in Sheet   G H I J K L M N  O  P  Q
'     Columns in Output  G H E I - [K] L  M  P  Q
'     Column Num Output  7   5 9    11 12 13 16 17
'     Columns to check   Y   Y Y    Y  Y  Y  Y  Y

For I = FMRow + 1 To TORow
    
    If WS.Cells(I, "F") <> "" Then
        wsopt.UsedRange.AutoFilter 1, Criteria1:=""
        If WS.Cells(I, "G") <> "" Then wsopt.UsedRange.AutoFilter 7, WS.Cells(I, "G")
        If WS.Cells(I, "I") <> "" Then wsopt.UsedRange.AutoFilter 5, WS.Cells(I, "I")
        If WS.Cells(I, "J") <> "" Then wsopt.UsedRange.AutoFilter 9, WS.Cells(I, "J")
        If WS.Cells(I, "L") <> "" Then
            If Len(WS.Cells(I, "L")) = 3 Then
                On Error Resume Next
                STMonth = DateSerial(WS.Cells(I, "M"), Month(DateValue(WS.Cells(I, "L") & " 1," & Year(Now))), 1)
                ENDMonth = DateSerial(Year(STMonth), Month(STMonth), Day(Application.WorksheetFunction.EoMonth(STMonth, 0)))
                wsopt.UsedRange.AutoFilter 11, Criteria1:=">=" & STMonth, Operator:=xlAnd, Criteria2:="<=" & ENDMonth
            Else
                On Error Resume Next
                STMonth = DateValue(Left(WS.Cells(I, "L"), 3) & " " & Right(WS.Cells(I, "L"), Len(WS.Cells(I, "L")) - 3) & "," & WS.Cells(I, "M"))
                wsopt.UsedRange.AutoFilter 11, Criteria1:=">=" & STMonth, Operator:=xlAnd, Criteria2:="<=" & STMonth
            End If
        End If
        On Error GoTo 0
        If WS.Cells(I, "N") <> "" And InStr(1, WS.Cells(I, "N"), "/") = 0 Then wsopt.UsedRange.AutoFilter 12, WS.Cells(I, "N")
        If WS.Cells(I, "O") <> "" And InStr(1, WS.Cells(I, "N"), "/") = 0 Then wsopt.UsedRange.AutoFilter 13, WS.Cells(I, "O")
        'If WS.Cells(I, "P") <> "" Then wsopt.UsedRange.AutoFilter 16, Criteria1:="<=" & Val(Right(WS.Cells(I, "P"), Len(WS.Cells(I, "P")) - 1))
        If WS.Cells(I, "Q") <> "" Then wsopt.UsedRange.AutoFilter 17, WS.Cells(I, "Q")
        NoteFound = NoteFound + 1
        FoundIT = True
        
        For Each Row In wsopt.Range("11:" & MaxRow).EntireRow.SpecialCells(xlCellTypeVisible).Rows
            If wsopt.Cells(Row.Row, "A").EntireRow.Hidden = False And wsopt.Cells(Row.Row, "C") <> "" And Row.Row <> 11 Then
                wsopt.Cells(Row.Row, "A") = WS.Cells(I, "F")
                RowMatched = RowMatched + 1
                FoundIT = False
                Exit For
            End If
        Next Row
        
        If FoundIT Then
            'MsgBox (WS.Cells(I, "F") & Chr(10) & "Was not mached in sheet Output !")
            WS.Cells(I, "F").Interior.ColorIndex = 3
            UnMatchedNotes = UnMatchedNotes + 1
        End If
        
        '---> Clear All Filters
        wsopt.UsedRange.AutoFilter 1
        wsopt.UsedRange.AutoFilter 5
        wsopt.UsedRange.AutoFilter 7
        wsopt.UsedRange.AutoFilter 9
        wsopt.UsedRange.AutoFilter 11
        wsopt.UsedRange.AutoFilter 12
        wsopt.UsedRange.AutoFilter 13
        wsopt.UsedRange.AutoFilter 16
        wsopt.UsedRange.AutoFilter 17
    End If
Next I

MsgBox ("A total of " & RowMatched & " Spread items were matched with notes." & Chr(10) _
& "A total of " & NoteFound & " Notes FILLED were found in the Order History Section." & Chr(10) _
& "A total of " & UnMatchedNotes & " Notes were not Matched in Sheet Output.")

End Sub
Private Sub cleanOutput()
Dim r As Range, rng As Range
Dim lastRow As Long
Dim cntAddr As String

    'assumes output tab just generated and thus doesn't have total row already, etc., as it had been previously cleared...
    
    'Freeze panes on the first 11 rows so that the header row will always be visible when scrolling.

    ThisWorkbook.Activate 'just in case another workbook is on top

    wsopt.Activate 'just in case another worksheet is in focus
    wsopt.Range("12:12").Select
    ActiveWindow.FreezePanes = False
    ActiveWindow.FreezePanes = True
    
    'Shorten the name of the Order Type column to just Order.
    
    wsopt.Range("Q11").Value = "Order"
    
    'Rename the OT column to say Period and the data in it where M becomes Monthly spelled out, and O becomes Other spelled out.
    
    wsopt.Range("J11").Value = "Period"
    
    lastRow = wsopt.Range("A" & wsopt.Rows.Count).End(xlUp).Row
    Set r = wsopt.Range(wsopt.Range("J12"), wsopt.Cells(lastRow, "J"))
    
    'in case none found, turn on error trap
    On Error Resume Next
    r.Replace what:="M", replacement:="Monthly", lookAt:=xlWhole
    r.Replace what:="O", replacement:="Other", lookAt:=xlWhole
    On Error GoTo 0
    
    'Left justify the data in all columns except for P#, S#, L#, Qty, Strike, Days which should be centered.
    
'MOST DATA CENTERED - However, all the remaining data columns themselves with the exception of Qty should be centered. This will improve readability a great deal. Qty is different though because of the minus (-) sign. My thinking is that it should be right justified with a 2 space offset to give the illusion that it is centered also but still take into account the minus (-) sign in front of some of the numbers.
       
    Set r = wsopt.Range(wsopt.Range("B12"), wsopt.Cells(lastRow, "S"))
    With r
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    
    'now make Notes left justified
    Set r = wsopt.Range("A12:A" & lastRow)
    With r
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
    End With
    
    'and O, P, R & S should be right justified
    Set r = Union(wsopt.Range("O12:O" & lastRow), wsopt.Range("P12:P" & lastRow), wsopt.Range("R12:R" & lastRow), wsopt.Range("S12:S" & lastRow))
    With r
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
    End With
    
    'format Qty so numbers without negatives are one space over
    Set r = wsopt.Range("H12:H" & lastRow)
    r.NumberFormat = "[<0]-0;+0"
    
    Set r = wsopt.Range("N12:N" & lastRow)
    r.NumberFormat = "[<0]0;0"
    
    
    'Add a Total Row at the bottom that simply displays a count for the number notes that are filled in for that column, and leaves every other total empty.
    Call Add_TotalRow_2_ExistingTable
    cntAddr = wsopt.Range(wsopt.Cells(12, 1), wsopt.Cells(lastRow, 1)).Address
    wsopt.Range("A" & lastRow + 1).Formula = "=COUNTA(" & cntAddr & ")"

    
'COMPLETE HEADINGS - Adjust macro to replace column headings in the resulting Output tab for P#, S#, and L# and instead use headings Pos#, Spread# and Leg#.
    wsopt.Range("B11").Value = "Pos#"
    wsopt.Range("D11").Value = "Spread#"
    wsopt.Range("F11").Value = "Leg#"
'HEADER LEFT - A reconsideration of the formatting rules leads me to believe that the header row of the resulting Output tab as well as the data in the Notes column should still be left justified.
    With wsopt.Range("A11:S11")
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
    End With
   
    'Auto-fit all columns to width of data with the exception of the Notes column.
    wsopt.Range("B:S").EntireColumn.AutoFit
        
    'fix header row
    With Range("A11:S11").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
    Call highlightSpreads(lastRow)
    
    'Always return focus to cell A1.
    wsopt.Range("A1").Select
    ActiveWindow.ScrollRow = 1
    ActiveWindow.ScrollColumn = 1

End Sub
Sub highlightSpreads(lastRow As Long)
Dim r As Range
Dim rng As Range
Dim lastSpread As Long
Dim topSpread As Range
Dim botSpread As Range
Dim rSpread As Range
'Dark Red: R61 / G10 / B10 / #3D0A0A
'Dark Green: R10 / G61 / B10 / #0A3D0A

    Set rng = wsopt.Range("D12:D" & lastRow)
    
    lastSpread = rng.Cells(1, 1).Value
    Set topSpread = rng.Cells(1, 1)
    Set botSpread = rng.Cells(1, 1)
    
    For Each r In rng
        If r.Font.Color <> vbWhite Then
            If r.Value = lastSpread Then
                Set botSpread = r
            Else
                If botSpread.Row > topSpread.Row Then
                    'highlight spread
                    Set rSpread = wsopt.Range(wsopt.Cells(topSpread.Row, "A"), wsopt.Cells(botSpread.Row, "S"))
                    If topSpread.Offset(, 3).Value = "BUY" Then
                        rSpread.Interior.Color = RGB(10, 61, 10) 'vbGreen
                        'rSpread.Font.Color = 1
                    Else
                        rSpread.Interior.Color = RGB(61, 10, 10) 'vbRed
                        'rspread.Font.Color = 1
                    End If
                End If

                lastSpread = r.Value
                Set topSpread = r
                Set botSpread = r
            End If
        End If
    Next r
End Sub
Private Sub Add_TotalRow_2_ExistingTable()
'Source adapted from:http://vbadud.blogspot.com/2008/07/add-total-row-to-excel-table-using-vba.html
Dim oWS As Worksheet ' Worksheet Object
Dim oRange As Range ' Range Object - Contains Represents the List of Items that need to be made unique
Dim oLst As ListObject ' List Object
Dim oLC As ListColumn ' List Column Object


On Error GoTo Disp_Error

Set oWS = ActiveSheet
If oWS.ListObjects.Count = 0 Then Exit Sub

Set oLst = oWS.ListObjects(1)
oLst.ShowTotals = True

' Change/Set the formatting of the Totals Row
oLst.TotalsRowRange.Font.Bold = True
'oLst.TotalsRowRange.Font.Color = vbRed


If Not oLC Is Nothing Then Set oLC = Nothing
If Not oLst Is Nothing Then Set oLst = Nothing
If Not oWS Is Nothing Then Set oWS = Nothing

' --------------------
' Error Handling
' --------------------
Disp_Error:
If Err <> 0 Then
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, "VBA Tips & Tricks Examples"
Resume Next
End If


End Sub

Open in new window


Dave
0
 
dlmilleCommented:
Aha!  It was easier than I'd thought.  I had to track down your color matching question to get the gold font color which wasn't specified in the OP.

Here's the final code:

 
'INTRODUCTION TO MACRO'

'!! Output tabs are created when the macro is run against a selected sheet in the Workbook.'

'1. This macro first looks to see which tab is selected and identifies a data type of rm or pm based'
'solely on the way the data appears within it.

'2. It then copies the data from the Trade History section of the original tab and creates a properly'
'formatted Output tab with a table for the that data where it continues to sort each Spread into'
'meaningful positions.'

'3. It then tries to also copy the notes from the original Order History section into the appropriate'
'cell for each Spread.'

'4. Just like with creating the table, the notes rely heavily on determining whether the originating'
'data type is rm or pm.'

'5. It then cleans the output providing correctly alligned data and returns the focus to A1.

'6. Future development will include making some calculations on each overall position.'

Option Explicit

Const AOH = "Account Order History"
Const ATH = "Account Trade History"
Const PAL = "Profits and Losses"
Const EQT = "Equities"
Const OPT = "Options"
Const OTH = "Others"
Const FRX = "Forex"

Dim wsopt As Worksheet
    

Private Sub AddMOColumn()
'This Sub will Add A new Column before Exp Column J that should indicate either of the following
'M for Monthly when the date in Exp is formated as Mmm-yy the date should be the 3rd friday of the month
'O for Weekly or Quarterly options


Dim MaxRow As Long, I As Long
Dim dDate As Date
Dim ThirdThuOfTheMonth As Date
Dim a

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row
wsopt.Select
Columns("J:J").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("J11") = "OT"

For I = 12 To MaxRow
    If wsopt.Cells(I, "K") <> "" Then
        If wsopt.Cells(I, "K").NumberFormat = "mmm-dd-yy" Then
            wsopt.Cells(I, "J") = "O"
        Else
            wsopt.Cells(I, "J") = "M"
            dDate = wsopt.Cells(I, "K")
            dDate = DateSerial(Year(dDate), Month(dDate), 1)
            Select Case Weekday(dDate)
                Case 5  'If Date is a Thursday then add 14 days
                    ThirdThuOfTheMonth = DateValue(dDate + 14)
                Case Is > 5 'If Date is Friday or saturday then add 21+1 days
                    ThirdThuOfTheMonth = DateValue(dDate + 21 - (Weekday(dDate) - vbThursday))
                Case Is < 5 'If Date is Sunday to Thurthday then add 14+ diffrence to friday days
                    ThirdThuOfTheMonth = DateValue(dDate + 14 + vbThursday - Weekday(dDate))
            End Select
            If Weekday(ThirdThuOfTheMonth) <> vbThursday Then
                MsgBox ("this date: " & ThirdThuOfTheMonth & " does not corespond to a Thursday! on row " & I & " Please check that date in Col K is actually a valid date then re-run the whole macro.")
            End If
            wsopt.Cells(I, "K") = ThirdThuOfTheMonth
        End If
    End If
Next I
End Sub

Private Sub AddDaysandPLColumn()
'This Sub will Add 3 new Columns
'Days to Exp in Col N next to type Column which should be the diffrence in days between Exec Time and Exp
'P/L Balance Col R
'P/L% Col S


Dim MaxRow As Long, I As Long
Dim dDate As Date
Dim ThirdThuOfTheMonth As Date
Dim a

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row
wsopt.Select
Columns("N:N").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("N11") = "Days to Exp"
Columns("R:S").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("R11") = "P/L Balance"
wsopt.Range("S11") = "P/L %"


For I = 12 To MaxRow
    If wsopt.Cells(I, "K") <> "" Then
        wsopt.Cells(I, "N") = DateValue(wsopt.Cells(I, "C")) - DateValue(wsopt.Cells(I, "K"))
    End If
    
    
Next I
End Sub


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
    Dim FirstAddress As String
    
    On Error GoTo Whoa
    
    Application.ScreenUpdating = True
    
    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
        
        If LCase(Left(shName, 2)) = "pm" Then
            '--> Find the "Options" cell in Sheet PM'
            Set bCell = wsPM.Columns(1).Find(what:=OPT, LookIn:=xlFormulas, _
            lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        
            If bCell Is Nothing Then
            '--> Find the "Forex" cell in Sheet PM if Options is not found'
                Set bCell = wsPM.Columns(1).Find(what:=FRX, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
            
            If bCell Is Nothing Then
            '--> Find the "Profits and Losses" cell in Sheet PM if Forex is not found'
                Set bCell = wsPM.Columns(1).Find(what:=PAL, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
        End If
        
        If LCase(Left(shName, 2)) = "rm" Then
            '--> Find the "Equities" cell in Sheet RM'
            Set bCell = wsPM.Columns(1).Find(what:=EQT, LookIn:=xlFormulas, _
            lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
            
            If bCell Is Nothing Then
            '--> Find the "Others" cell in Sheet RM if Equities is not found
                Set bCell = wsPM.Columns(1).Find(what:=OTH, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
        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 LCase(Left(shName, 2)) = "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.
                    wsPM.Range("IV:IV").ClearContents
                    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
                            wsPM.Range("IV" & I).Value = SearchString
                    Next I
                
                    For J = 2 To lastRow
                        MatchString = .Range("D" & J).Value & "###" & _
                                        .Range("F" & J).Value & "###" & _
                                        .Range("G" & J).Value & "###" & _
                                        .Range("H" & J).Value & "###" & _
                                        .Range("I" & J).Value
                
                            Set cCell = wsPM.Range("IV:IV").Find(what:=MatchString, LookIn:=xlFormulas, _
                                        lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                        MatchCase:=False, SearchFormat:=False)
                            If Not cCell Is Nothing Then
                                FirstAddress = cCell.Address
                                    Do
                                        If wsopt.Range("F" & J).Value = wsPM.Range("F" & cCell.Row).Value Then
                                            .Range("A" & J).Value = wsPM.Range("A" & cCell.Row).Value
                                            Exit Do
                                        Else
                                            Set cCell = wsPM.Range("IV:IV").FindNext(cCell)
                                        End If
                                    Loop While Not cCell Is Nothing And cCell.Address <> FirstAddress
                            End If
                    Next J
                End If
                GoTo There

                '--> Copy the notes into the new notes column. old'
                    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
                
There:
                '--> 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
    FixDate
    Indexing
    Sorting
    AddMOColumn
    AddDaysandPLColumn
    If LCase(Left(shName, 2)) = "rm" Then
        UpdateNotes wsPM, AOHRow, ATHRow
    End If
    
    wsopt.Cells(1, 1).Select

    Call cleanOutput
    
    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 FixDate()
'This Sub will go thru Exp Column Col J and will Fix the date to allow for either mm-yy or mmm-dd-yy.

Dim MaxRow As Long, I As Long
Dim tmpM As String, tmpD As String, tmpY As String

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row

For I = 12 To MaxRow
    '---> Strip Dates and Fix them
    If wsopt.Cells(I, "J") <> "" Then
        If IsDate(wsopt.Cells(I, "J")) Then
            '---> Format normally if normal Date format as 'mmm-dd-yy'
            wsopt.Cells(I, "J").NumberFormat = "Mmm-yy"
        Else
            '---> Strip the date in Day month Year then re-group so system would recognize
            '     it as a date and then apply format 'mmm-yy'
            tmpM = Left(wsopt.Cells(I, "J"), 3)
            tmpY = Right(wsopt.Cells(I, "J"), 2)
            tmpD = Mid(wsopt.Cells(I, "J"), 4, Len(wsopt.Cells(I, "J")) - 6)
            wsopt.Cells(I, "J") = tmpM & " " & Format(Val(tmpD), "") & ", " & Format(Val(tmpY), "")
            wsopt.Cells(I, "J").NumberFormat = "Mmm-dd-yy"
        End If
    End If

Next I

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
ActiveSheet.PageSetup.PrintArea = ""
wsopt.PageSetup.FitToPagesWide = 1
wsopt.PageSetup.FitToPagesTall = 1

End Sub

'DEFINITIONS - Definitions to understand prior to Indexing and Ordering'
'1. Positions - Positions can be made up of more than one Spread and the newest Positions appear at the top of the sheet.'
'2. Spreads - Spreads can be made up of more than one Leg and their order with a position can change.'
'3. Legs - Legs are made up of individual rows within a Spread and there order within the spread never changes.'

'It is important to note that spreads always belong together in the same position if any of its legs
'contain the same Symbol Exp Strike, and Type of any other spread within the sheet.'

Private Sub Indexing()
'Each Position, Spread, and Leg is indexed with a number according to the value in its Exec Date column.'
'P# - Positions are numbered sequentially with 1 being  meaning that it contains a newer Exec Date than any other positions.'
'S# - Spreads are numbered sequentially with 1 meaning that it contains the a newer Exec Date than the other spreads.'
'L# - 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 alphabetical order.'

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)
    'dlmille no grey - 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()

'Positions can contain single or multi-legged spreads but the sort order of the legs 'within' each'
'spread never changes. This is an important point because by contrast, the sort order in which each
'spread appears within the overall position does indeed change. Here the oldest spreads should'
'appear at the top of the position while newer spreads should appear at the bottom of the position.'

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 wsopt.Range("B" & I) <> wsopt.Range("B" & I - 1) And wsopt.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
wsopt.Sort.SortFields.Add Key:=wsopt.Range("C11"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

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
        
         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.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
    'dlmille no grey - 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

Sub UpdateNotes(WS As Worksheet, FMRow As Long, TORow As Long)
'This Sub will update noted for rm sheets from the Account Order History section in Col A
'To match with data in the Output file created under wsopt variable.

Dim MaxRow As Long, I As Long, J As Long, K As Long, Z As Long
Dim Note As String
Dim NoteItem
Dim Row As Range
Dim Status
Dim ParClose As Long, RowMatched As Long, UnMatchedNotes As Long, NoteFound As Long
Dim BkRatio As Boolean, FoundIT As Boolean
Dim STMonth As Date, ENDMonth As Date


MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row

'---> Clean the Area F to Z to dissec Notes
WS.Range("F" & FMRow & ":ZZ" & TORow).ClearContents
WS.Range("F" & FMRow & ":ZZ" & TORow).ClearFormats


'---> Clean the notes and copy to Col F only for Status Filled Notes
For I = FMRow + 1 To TORow
    Status = Split(WS.Cells(I, "D"), " ")
    For J = 0 To UBound(Status)
        If UCase(Status(J)) = "FILLED" Then
            '---> If a note start with (Replacing ... then remove the first part till the first space
            If Left(WS.Cells(I, "C"), 10) = "(Replacing" Then
                ParClose = InStr(1, WS.Cells(I, "C"), ")")
            Else
                ParClose = 0
            End If
            
            If ParClose <> 0 Then
                WS.Cells(I, "F") = Mid(WS.Cells(I, "C"), ParClose + 2, Len(WS.Cells(I, "C")) - ParClose - 1)
            Else
                WS.Cells(I, "F") = WS.Cells(I, "C")
            End If
            Note = WS.Cells(I, "F")
            NoteItem = Split(Note, " ")
            Z = 0
            
            '---> Check to see if BACKRATIO is found then treat the sequence diffrently
            If InStr(1, WS.Cells(I, "F"), "BACKRATIO") <> 0 Then
                BkRatio = True
            Else
                BkRatio = False
            End If
            
            '---> Loop thru all items in the Note
            For K = 0 To UBound(NoteItem)
                '---> Remove any items that has open/close brakets as this is comment
                If Left(NoteItem(K), 1) = "(" Or Right(NoteItem(K), 1) = ")" Then
                    K = K + 1
                    Z = Z - 1
                End If
                
                '---> Remove any first letter / at first position
                If Left(NoteItem(K), 1) = "/" Then NoteItem(K) = Right(NoteItem(K), Len(NoteItem(K)) - 1)
                
                '---> Keep only VERTICAL/BUTTERFLY/STRANGLE/DIAGONAL in Second position
                If K = 2 Then
                    If UCase(NoteItem(K)) = "VERTICAL" Or _
                       UCase(NoteItem(K)) = "BUTTERFLY" Or _
                       UCase(NoteItem(K)) = "STRANGLE" Or _
                       UCase(NoteItem(K)) = "DIAGONAL" Then
                        Z = 0
                    Else
                        Z = 1
                    End If
                End If
                
                If BkRatio Then
                    '---> If BACKRATIO encountered then treat the sequence diffrently.
                    Select Case K
                    Case 0
                        WS.Cells(I, K + 7).NumberFormat = "@"
                        WS.Cells(I, K + 7) = Format(NoteItem(0), "@")
                    Case 1, 2
                        WS.Cells(I, 7 + 1).NumberFormat = "@"
                        WS.Cells(I, 7 + 1) = Format(NoteItem(1) & " " & NoteItem(2), "@")
                    Case Else
                        WS.Cells(I, K + 7 - 1).NumberFormat = "@"
                        WS.Cells(I, K + 7 - 1) = Format(NoteItem(K), "@")
                    End Select
                Else
                    
                    If InStr(1, Note, "@") <> 0 Then
                        '---> in any sequence is @ is encountered make sure it is positioned
                        '     in Col P as it is the Price Column the rest will follow.
                        If Left(NoteItem(K), 1) = "@" And K + 7 + Z <> 16 Then
                            Z = 16 - 7 - K
                        End If
                    Else
                        If K + 7 + Z = 16 Then
                            Z = 16 - 7 - K + 1
                        End If
                    End If
                    WS.Cells(I, K + 7 + Z).NumberFormat = "@"
                    WS.Cells(I, K + 7 + Z) = Format(NoteItem(K), "@")
                End If
            Next K
        End If
    Next J
Next I


'---> Loop Again thru all the notes in the Account Order History section
'     and match the columns where there is data to find the threads in sheet output
'     Columns in Sheet   G H I J K L M N  O  P  Q
'     Columns in Output  G H E I - [K] L  M  P  Q
'     Column Num Output  7   5 9    11 12 13 16 17
'     Columns to check   Y   Y Y    Y  Y  Y  Y  Y

For I = FMRow + 1 To TORow
    
    If WS.Cells(I, "F") <> "" Then
        wsopt.UsedRange.AutoFilter 1, Criteria1:=""
        If WS.Cells(I, "G") <> "" Then wsopt.UsedRange.AutoFilter 7, WS.Cells(I, "G")
        If WS.Cells(I, "I") <> "" Then wsopt.UsedRange.AutoFilter 5, WS.Cells(I, "I")
        If WS.Cells(I, "J") <> "" Then wsopt.UsedRange.AutoFilter 9, WS.Cells(I, "J")
        If WS.Cells(I, "L") <> "" Then
            If Len(WS.Cells(I, "L")) = 3 Then
                On Error Resume Next
                STMonth = DateSerial(WS.Cells(I, "M"), Month(DateValue(WS.Cells(I, "L") & " 1," & Year(Now))), 1)
                ENDMonth = DateSerial(Year(STMonth), Month(STMonth), Day(Application.WorksheetFunction.EoMonth(STMonth, 0)))
                wsopt.UsedRange.AutoFilter 11, Criteria1:=">=" & STMonth, Operator:=xlAnd, Criteria2:="<=" & ENDMonth
            Else
                On Error Resume Next
                STMonth = DateValue(Left(WS.Cells(I, "L"), 3) & " " & Right(WS.Cells(I, "L"), Len(WS.Cells(I, "L")) - 3) & "," & WS.Cells(I, "M"))
                wsopt.UsedRange.AutoFilter 11, Criteria1:=">=" & STMonth, Operator:=xlAnd, Criteria2:="<=" & STMonth
            End If
        End If
        On Error GoTo 0
        If WS.Cells(I, "N") <> "" And InStr(1, WS.Cells(I, "N"), "/") = 0 Then wsopt.UsedRange.AutoFilter 12, WS.Cells(I, "N")
        If WS.Cells(I, "O") <> "" And InStr(1, WS.Cells(I, "N"), "/") = 0 Then wsopt.UsedRange.AutoFilter 13, WS.Cells(I, "O")
        'If WS.Cells(I, "P") <> "" Then wsopt.UsedRange.AutoFilter 16, Criteria1:="<=" & Val(Right(WS.Cells(I, "P"), Len(WS.Cells(I, "P")) - 1))
        If WS.Cells(I, "Q") <> "" Then wsopt.UsedRange.AutoFilter 17, WS.Cells(I, "Q")
        NoteFound = NoteFound + 1
        FoundIT = True
        
        For Each Row In wsopt.Range("11:" & MaxRow).EntireRow.SpecialCells(xlCellTypeVisible).Rows
            If wsopt.Cells(Row.Row, "A").EntireRow.Hidden = False And wsopt.Cells(Row.Row, "C") <> "" And Row.Row <> 11 Then
                wsopt.Cells(Row.Row, "A") = WS.Cells(I, "F")
                RowMatched = RowMatched + 1
                FoundIT = False
                Exit For
            End If
        Next Row
        
        If FoundIT Then
            'MsgBox (WS.Cells(I, "F") & Chr(10) & "Was not mached in sheet Output !")
            WS.Cells(I, "F").Interior.ColorIndex = 3
            UnMatchedNotes = UnMatchedNotes + 1
        End If
        
        '---> Clear All Filters
        wsopt.UsedRange.AutoFilter 1
        wsopt.UsedRange.AutoFilter 5
        wsopt.UsedRange.AutoFilter 7
        wsopt.UsedRange.AutoFilter 9
        wsopt.UsedRange.AutoFilter 11
        wsopt.UsedRange.AutoFilter 12
        wsopt.UsedRange.AutoFilter 13
        wsopt.UsedRange.AutoFilter 16
        wsopt.UsedRange.AutoFilter 17
    End If
Next I

MsgBox ("A total of " & RowMatched & " Spread items were matched with notes." & Chr(10) _
& "A total of " & NoteFound & " Notes FILLED were found in the Order History Section." & Chr(10) _
& "A total of " & UnMatchedNotes & " Notes were not Matched in Sheet Output.")

End Sub
Private Sub cleanOutput()
Dim r As Range, rng As Range
Dim lastRow As Long
Dim cntAddr As String

    'assumes output tab just generated and thus doesn't have total row already, etc., as it had been previously cleared...
    
    'Freeze panes on the first 11 rows so that the header row will always be visible when scrolling.

    ThisWorkbook.Activate 'just in case another workbook is on top

    wsopt.Activate 'just in case another worksheet is in focus
    wsopt.Range("12:12").Select
    ActiveWindow.FreezePanes = False
    ActiveWindow.FreezePanes = True
    
    'Shorten the name of the Order Type column to just Order.
    
    wsopt.Range("Q11").Value = "Order"
    
    'Rename the OT column to say Period and the data in it where M becomes Monthly spelled out, and O becomes Other spelled out.
    
    wsopt.Range("J11").Value = "Period"
    
    lastRow = wsopt.Range("A" & wsopt.Rows.Count).End(xlUp).Row
    Set r = wsopt.Range(wsopt.Range("J12"), wsopt.Cells(lastRow, "J"))
    
    'in case none found, turn on error trap
    On Error Resume Next
    r.Replace what:="M", replacement:="Monthly", lookAt:=xlWhole
    r.Replace what:="O", replacement:="Other", lookAt:=xlWhole
    On Error GoTo 0
    
    'Left justify the data in all columns except for P#, S#, L#, Qty, Strike, Days which should be centered.
    
'MOST DATA CENTERED - However, all the remaining data columns themselves with the exception of Qty should be centered. This will improve readability a great deal. Qty is different though because of the minus (-) sign. My thinking is that it should be right justified with a 2 space offset to give the illusion that it is centered also but still take into account the minus (-) sign in front of some of the numbers.
       
    Set r = wsopt.Range(wsopt.Range("B12"), wsopt.Cells(lastRow, "S"))
    With r
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    
    'now make Notes left justified
    Set r = wsopt.Range("A12:A" & lastRow)
    With r
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
    End With
    
    'and O, P, R & S should be right justified
    Set r = Union(wsopt.Range("O12:O" & lastRow), wsopt.Range("P12:P" & lastRow), wsopt.Range("R12:R" & lastRow), wsopt.Range("S12:S" & lastRow))
    With r
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
    End With
    
    'format Qty so numbers without negatives are one space over
    Set r = wsopt.Range("H12:H" & lastRow)
    r.NumberFormat = "[<0]-0;+0"
    
    Set r = wsopt.Range("N12:N" & lastRow)
    r.NumberFormat = "[<0]0;0"
    
    
    'Add a Total Row at the bottom that simply displays a count for the number notes that are filled in for that column, and leaves every other total empty.
    Call Add_TotalRow_2_ExistingTable
    cntAddr = wsopt.Range(wsopt.Cells(12, 1), wsopt.Cells(lastRow, 1)).Address
    wsopt.Range("A" & lastRow + 1).Formula = "=COUNTA(" & cntAddr & ")"

    
'COMPLETE HEADINGS - Adjust macro to replace column headings in the resulting Output tab for P#, S#, and L# and instead use headings Pos#, Spread# and Leg#.
    wsopt.Range("B11").Value = "Pos#"
    wsopt.Range("D11").Value = "Spread#"
    wsopt.Range("F11").Value = "Leg#"
'HEADER LEFT - A reconsideration of the formatting rules leads me to believe that the header row of the resulting Output tab as well as the data in the Notes column should still be left justified.
    With wsopt.Range("A11:S11")
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
    End With
   
    'Auto-fit all columns to width of data with the exception of the Notes column.
    wsopt.Range("B:S").EntireColumn.AutoFit
        
    'fix header row
    With Range("A11:S11").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
    Call highlightSpreads(lastRow)
    
    'Always return focus to cell A1.
    wsopt.Range("A1").Select
    ActiveWindow.ScrollRow = 1
    ActiveWindow.ScrollColumn = 1

End Sub
Sub highlightSpreads(lastRow As Long)
Dim r As Range
Dim rng As Range
Dim lastSpread As Long
Dim topSpread As Range
Dim botSpread As Range
Dim rSpread As Range
'Dark Red: R61 / G10 / B10 / #3D0A0A
'Dark Green: R10 / G61 / B10 / #0A3D0A

    Set rng = wsopt.Range("D12:D" & lastRow)
    
    lastSpread = rng.Cells(1, 1).Value
    Set topSpread = rng.Cells(1, 1)
    Set botSpread = rng.Cells(1, 1)
    
    For Each r In rng
        If r.Font.Color <> vbWhite Then
            If r.Value = lastSpread Then
                Set botSpread = r
            Else
                If botSpread.Row > topSpread.Row Then
                    'highlight spread
                    Set rSpread = wsopt.Range(wsopt.Cells(topSpread.Row, "A"), wsopt.Cells(botSpread.Row, "S"))
                    If topSpread.Offset(, 3).Value = "BUY" Then
                        rSpread.Interior.Color = RGB(10, 61, 10) 'vbGreen
                        rSpread.Font.Color = RGB(255, 220, 0)
                    Else
                        rSpread.Interior.Color = RGB(61, 10, 10) 'vbRed
                        rSpread.Font.Color = RGB(255, 220, 10)
                    End If
                End If

                lastSpread = r.Value
                Set topSpread = r
                Set botSpread = r
            End If
        End If
    Next r
End Sub
Private Sub Add_TotalRow_2_ExistingTable()
'Source adapted from:http://vbadud.blogspot.com/2008/07/add-total-row-to-excel-table-using-vba.html
Dim oWS As Worksheet ' Worksheet Object
Dim oRange As Range ' Range Object - Contains Represents the List of Items that need to be made unique
Dim oLst As ListObject ' List Object
Dim oLC As ListColumn ' List Column Object


On Error GoTo Disp_Error

Set oWS = ActiveSheet
If oWS.ListObjects.Count = 0 Then Exit Sub

Set oLst = oWS.ListObjects(1)
oLst.ShowTotals = True

' Change/Set the formatting of the Totals Row
oLst.TotalsRowRange.Font.Bold = True
'oLst.TotalsRowRange.Font.Color = vbRed


If Not oLC Is Nothing Then Set oLC = Nothing
If Not oLst Is Nothing Then Set oLst = Nothing
If Not oWS Is Nothing Then Set oWS = Nothing

' --------------------
' Error Handling
' --------------------
Disp_Error:
If Err <> 0 Then
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, "VBA Tips & Tricks Examples"
Resume Next
End If


End Sub

Open in new window

Cheers,

Dave
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

 
rtod2Author Commented:
Dave, thank you.  Not quite though.  I ran it against the pm full with notes tab and it created an Output tab plus two additional empty tabs which is not desired but the rule set we are using is the most critical.  The rule is as follows.

RULE:  If the 1st Leg of any Spread is a buy then it is dark green and if a sell then it is dark red.  That's it.

Note that a Spread can consist of multiple Legs (rows) but does not have to. It can be just one row. Also each Spread has a unique number to indicate it. Verticals for instance, have only one Leg, while Butterflies have three Legs.  Regardless of how many Legs a spread has, the rule above is the same.

In the one I tested, not every Spread got colored where all spreads should have gotten either dark green or dark red.

Thank you again sir.
0
 
rtod2Author Commented:
Dave, here is a video for you also http://screencast.com/t/cPfN3BkwuY, describing what is meant by the fore-mentioned rule.
0
 
gowflowCommented:
Hi rtod2
Is this what your looking for ?
gowflow
'INTRODUCTION TO MACRO'

'!! Output tabs are created when the macro is run against a selected sheet in the Workbook.'

'1. This macro first looks to see which tab is selected and identifies a data type of rm or pm based'
'solely on the way the data appears within it.

'2. It then copies the data from the Trade History section of the original tab and creates a properly'
'formatted Output tab with a table for the that data where it continues to sort each Spread into'
'meaningful positions.'

'3. It then tries to also copy the notes from the original Order History section into the appropriate'
'cell for each Spread.'

'4. Just like with creating the table, the notes rely heavily on determining whether the originating'
'data type is rm or pm.'

'5. It then cleans the output providing correctly alligned data and returns the focus to A1.

'6. Future development will include making some calculations on each overall position.'

Option Explicit

Const AOH = "Account Order History"
Const ATH = "Account Trade History"
Const PAL = "Profits and Losses"
Const EQT = "Equities"
Const OPT = "Options"
Const OTH = "Others"
Const FRX = "Forex"

Dim wsopt As Worksheet
    

Private Sub AddMOColumn()
'This Sub will Add A new Column before Exp Column J that should indicate either of the following
'M for Monthly when the date in Exp is formated as Mmm-yy the date should be the 3rd friday of the month
'O for Weekly or Quarterly options


Dim MaxRow As Long, I As Long
Dim dDate As Date
Dim ThirdThuOfTheMonth As Date
Dim a

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row
wsopt.Select
Columns("J:J").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("J11") = "OT"

For I = 12 To MaxRow
    If wsopt.Cells(I, "K") <> "" Then
        If wsopt.Cells(I, "K").NumberFormat = "mmm-dd-yy" Then
            wsopt.Cells(I, "J") = "O"
        Else
            wsopt.Cells(I, "J") = "M"
            dDate = wsopt.Cells(I, "K")
            dDate = DateSerial(Year(dDate), Month(dDate), 1)
            Select Case Weekday(dDate)
                Case 5  'If Date is a Thursday then add 14 days
                    ThirdThuOfTheMonth = DateValue(dDate + 14)
                Case Is > 5 'If Date is Friday or saturday then add 21+1 days
                    ThirdThuOfTheMonth = DateValue(dDate + 21 - (Weekday(dDate) - vbThursday))
                Case Is < 5 'If Date is Sunday to Thurthday then add 14+ diffrence to friday days
                    ThirdThuOfTheMonth = DateValue(dDate + 14 + vbThursday - Weekday(dDate))
            End Select
            If Weekday(ThirdThuOfTheMonth) <> vbThursday Then
                MsgBox ("this date: " & ThirdThuOfTheMonth & " does not corespond to a Thursday! on row " & I & " Please check that date in Col K is actually a valid date then re-run the whole macro.")
            End If
            wsopt.Cells(I, "K") = ThirdThuOfTheMonth
        End If
    End If
Next I
End Sub

Private Sub AddDaysandPLColumn()
'This Sub will Add 3 new Columns
'Days to Exp in Col N next to type Column which should be the diffrence in days between Exec Time and Exp
'P/L Balance Col R
'P/L% Col S


Dim MaxRow As Long, I As Long
Dim dDate As Date
Dim ThirdThuOfTheMonth As Date
Dim a

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row
wsopt.Select
Columns("N:N").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("N11") = "Days to Exp"
Columns("R:S").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("R11") = "P/L Balance"
wsopt.Range("S11") = "P/L %"


For I = 12 To MaxRow
    If wsopt.Cells(I, "K") <> "" Then
        wsopt.Cells(I, "N") = DateValue(wsopt.Cells(I, "C")) - DateValue(wsopt.Cells(I, "K"))
    End If
    
    
Next I
End Sub


Private Sub Coloring()
'This Sub will go color threads
'The header row should be black with white lettering
'1. Dark Green if the first Leg of the Spread is a Buy.
'2. Dark Red if the first Leg of the Spread is a Sell.


Dim MaxRow As Long, I As Long, j As Long
Dim tmpM As String, tmpD As String, tmpY As String

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row

wsopt.Range("A11:S11").Interior.ColorIndex = 1

For I = 12 To MaxRow
    If wsopt.Cells(I, "B").Font.ColorIndex <> 2 Then
        If wsopt.Cells(I, "G") = "SELL" Then
            wsopt.Range(wsopt.Cells(I, "A"), wsopt.Cells(I, "S")).Font.ColorIndex = 6
            wsopt.Range(wsopt.Cells(I, "A"), wsopt.Cells(I, "S")).Interior.ColorIndex = 9
        End If
        
        If wsopt.Cells(I, "G") = "BUY" Then
            wsopt.Range(wsopt.Cells(I, "A"), wsopt.Cells(I, "S")).Font.ColorIndex = 6
            wsopt.Range(wsopt.Cells(I, "A"), wsopt.Cells(I, "S")).Interior.ColorIndex = 10
        End If
    End If

Next I
wsopt.Range(wsopt.Cells(MaxRow + 1, "A"), wsopt.Cells(MaxRow + 1, "S")).Interior.ColorIndex = 1

End Sub

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
    Dim FirstAddress As String
    
    On Error GoTo Whoa
    
    Application.ScreenUpdating = True
    
    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
        
        If LCase(Left(shName, 2)) = "pm" Then
            '--> Find the "Options" cell in Sheet PM'
            Set bCell = wsPM.Columns(1).Find(what:=OPT, LookIn:=xlFormulas, _
            lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        
            If bCell Is Nothing Then
            '--> Find the "Forex" cell in Sheet PM if Options is not found'
                Set bCell = wsPM.Columns(1).Find(what:=FRX, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
            
            If bCell Is Nothing Then
            '--> Find the "Profits and Losses" cell in Sheet PM if Forex is not found'
                Set bCell = wsPM.Columns(1).Find(what:=PAL, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
        End If
        
        If LCase(Left(shName, 2)) = "rm" Then
            '--> Find the "Equities" cell in Sheet RM'
            Set bCell = wsPM.Columns(1).Find(what:=EQT, LookIn:=xlFormulas, _
            lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
            
            If bCell Is Nothing Then
            '--> Find the "Others" cell in Sheet RM if Equities is not found
                Set bCell = wsPM.Columns(1).Find(what:=OTH, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
        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 LCase(Left(shName, 2)) = "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.
                    wsPM.Range("IV:IV").ClearContents
                    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
                            wsPM.Range("IV" & I).Value = SearchString
                    Next I
                
                    For j = 2 To lastRow
                        MatchString = .Range("D" & j).Value & "###" & _
                                        .Range("F" & j).Value & "###" & _
                                        .Range("G" & j).Value & "###" & _
                                        .Range("H" & j).Value & "###" & _
                                        .Range("I" & j).Value
                
                            Set cCell = wsPM.Range("IV:IV").Find(what:=MatchString, LookIn:=xlFormulas, _
                                        lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                        MatchCase:=False, SearchFormat:=False)
                            If Not cCell Is Nothing Then
                                FirstAddress = cCell.Address
                                    Do
                                        If wsopt.Range("F" & j).Value = wsPM.Range("F" & cCell.Row).Value Then
                                            .Range("A" & j).Value = wsPM.Range("A" & cCell.Row).Value
                                            Exit Do
                                        Else
                                            Set cCell = wsPM.Range("IV:IV").FindNext(cCell)
                                        End If
                                    Loop While Not cCell Is Nothing And cCell.Address <> FirstAddress
                            End If
                    Next j
                End If
                GoTo There

                '--> Copy the notes into the new notes column. old'
                    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
                
There:
                '--> 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
    FixDate
    Indexing
    Sorting
    AddMOColumn
    AddDaysandPLColumn
    If LCase(Left(shName, 2)) = "rm" Then
        UpdateNotes wsPM, AOHRow, ATHRow
    End If
    Coloring
    
    wsopt.Cells(1, 1).Select

    Call cleanOutput
    
    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 cleanOutput()
Dim r As Range, rng As Range
Dim lastRow As Long
Dim cntAddr As String

    'assumes output tab just generated and thus doesn't have total row already, etc., as it had been previously cleared...
    
    'Freeze panes on the first 11 rows so that the header row will always be visible when scrolling.

    ThisWorkbook.Activate 'just in case another workbook is on top

    wsopt.Activate 'just in case another worksheet is in focus
    wsopt.Range("12:12").Select
    ActiveWindow.FreezePanes = False
    ActiveWindow.FreezePanes = True
    
    'Shorten the name of the Order Type column to just Order.
    
    wsopt.Range("Q11").Value = "Order"
    
    'Rename the OT column to say Period and the data in it where M becomes Monthly spelled out, and O becomes Other spelled out.
    
    wsopt.Range("J11").Value = "Period"
    
    lastRow = wsopt.Range("A" & wsopt.Rows.Count).End(xlUp).Row
    Set r = wsopt.Range(wsopt.Range("J12"), wsopt.Cells(lastRow, "J"))
    
    'in case none found, turn on error trap
    On Error Resume Next
    r.Replace what:="M", replacement:="Monthly", lookAt:=xlWhole
    r.Replace what:="O", replacement:="Other", lookAt:=xlWhole
    On Error GoTo 0
    
    'Left justify the data in all columns except for P#, S#, L#, Qty, Strike, Days which should be centered.
    
'MOST DATA CENTERED - However, all the remaining data columns themselves with the exception of Qty should be centered. This will improve readability a great deal. Qty is different though because of the minus (-) sign. My thinking is that it should be right justified with a 2 space offset to give the illusion that it is centered also but still take into account the minus (-) sign in front of some of the numbers.
       
    Set r = wsopt.Range(wsopt.Range("B12"), wsopt.Cells(lastRow, "S"))
    With r
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    
    'now make Notes left justified
    Set r = wsopt.Range("A12:A" & lastRow)
    With r
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
    End With
    
    'and O, P, R & S should be right justified
    Set r = Union(wsopt.Range("O12:O" & lastRow), wsopt.Range("P12:P" & lastRow), wsopt.Range("R12:R" & lastRow), wsopt.Range("S12:S" & lastRow))
    With r
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
    End With
    
    'format Qty so numbers without negatives are one space over
    Set r = wsopt.Range("H12:H" & lastRow)
    r.NumberFormat = "[<0]-0;+0"
    
    Set r = wsopt.Range("N12:N" & lastRow)
    r.NumberFormat = "[<0]0;0"
    
    
    'Add a Total Row at the bottom that simply displays a count for the number notes that are filled in for that column, and leaves every other total empty.
    Call Add_TotalRow_2_ExistingTable
    cntAddr = wsopt.Range(wsopt.Cells(12, 1), wsopt.Cells(lastRow, 1)).Address
    wsopt.Range("A" & lastRow + 1).Formula = "=COUNTA(" & cntAddr & ")"

    
'COMPLETE HEADINGS - Adjust macro to replace column headings in the resulting Output tab for P#, S#, and L# and instead use headings Pos#, Spread# and Leg#.
    wsopt.Range("B11").Value = "Pos#"
    wsopt.Range("D11").Value = "Spread#"
    wsopt.Range("F11").Value = "Leg#"
'HEADER LEFT - A reconsideration of the formatting rules leads me to believe that the header row of the resulting Output tab as well as the data in the Notes column should still be left justified.
    With wsopt.Range("A11:S11")
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
    End With
   
    'Auto-fit all columns to width of data with the exception of the Notes column.
    wsopt.Range("B:S").EntireColumn.AutoFit
        
    'Always return focus to cell A1.
    wsopt.Range("A1").Select
    ActiveWindow.ScrollRow = 1
    ActiveWindow.ScrollColumn = 1

End Sub
Private Sub FixDate()
'This Sub will go thru Exp Column Col J and will Fix the date to allow for either mm-yy or mmm-dd-yy.

Dim MaxRow As Long, I As Long
Dim tmpM As String, tmpD As String, tmpY As String

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row

For I = 12 To MaxRow
    '---> Strip Dates and Fix them
    If wsopt.Cells(I, "J") <> "" Then
        If IsDate(wsopt.Cells(I, "J")) Then
            '---> Format normally if normal Date format as 'mmm-dd-yy'
            wsopt.Cells(I, "J").NumberFormat = "Mmm-yy"
        Else
            '---> Strip the date in Day month Year then re-group so system would recognize
            '     it as a date and then apply format 'mmm-yy'
            tmpM = Left(wsopt.Cells(I, "J"), 3)
            tmpY = Right(wsopt.Cells(I, "J"), 2)
            tmpD = Mid(wsopt.Cells(I, "J"), 4, Len(wsopt.Cells(I, "J")) - 6)
            wsopt.Cells(I, "J") = tmpM & " " & Format(Val(tmpD), "") & ", " & Format(Val(tmpY), "")
            wsopt.Cells(I, "J").NumberFormat = "Mmm-dd-yy"
        End If
    End If

Next I

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
ActiveSheet.PageSetup.PrintArea = ""
wsopt.PageSetup.FitToPagesWide = 1
wsopt.PageSetup.FitToPagesTall = 1

End Sub

'DEFINITIONS - Definitions to understand prior to Indexing and Ordering'
'1. Positions - Positions can be made up of more than one Spread and the newest Positions appear at the top of the sheet.'
'2. Spreads - Spreads can be made up of more than one Leg and their order with a position can change.'
'3. Legs - Legs are made up of individual rows within a Spread and there order within the spread never changes.'

'It is important to note that spreads always belong together in the same position if any of its legs
'contain the same Symbol Exp Strike, and Type of any other spread within the sheet.'

Private Sub Indexing()
'Each Position, Spread, and Leg is indexed with a number according to the value in its Exec Date column.'
'P# - Positions are numbered sequentially with 1 being  meaning that it contains a newer Exec Date than any other positions.'
'S# - Spreads are numbered sequentially with 1 meaning that it contains the a newer Exec Date than the other spreads.'
'L# - 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 alphabetical order.'

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()

'Positions can contain single or multi-legged spreads but the sort order of the legs 'within' each'
'spread never changes. This is an important point because by contrast, the sort order in which each
'spread appears within the overall position does indeed change. Here the oldest spreads should'
'appear at the top of the position while newer spreads should appear at the bottom of the position.'

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 wsopt.Range("B" & I) <> wsopt.Range("B" & I - 1) And wsopt.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
wsopt.Sort.SortFields.Add Key:=wsopt.Range("C11"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

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
        
         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.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

Sub UpdateNotes(WS As Worksheet, FMRow As Long, TORow As Long)
'This Sub will update noted for rm sheets from the Account Order History section in Col A
'To match with data in the Output file created under wsopt variable.

Dim MaxRow As Long, I As Long, j As Long, K As Long, Z As Long
Dim Note As String
Dim NoteItem
Dim Row As Range
Dim Status
Dim ParClose As Long, RowMatched As Long, UnMatchedNotes As Long, NoteFound As Long
Dim BkRatio As Boolean, FoundIT As Boolean
Dim STMonth As Date, ENDMonth As Date


MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row

'---> Clean the Area F to Z to dissec Notes
WS.Range("F" & FMRow & ":ZZ" & TORow).ClearContents
WS.Range("F" & FMRow & ":ZZ" & TORow).ClearFormats


'---> Clean the notes and copy to Col F only for Status Filled Notes
For I = FMRow + 1 To TORow
    Status = Split(WS.Cells(I, "D"), " ")
    For j = 0 To UBound(Status)
        If UCase(Status(j)) = "FILLED" Then
            '---> If a note start with (Replacing ... then remove the first part till the first space
            If Left(WS.Cells(I, "C"), 10) = "(Replacing" Then
                ParClose = InStr(1, WS.Cells(I, "C"), ")")
            Else
                ParClose = 0
            End If
            
            If ParClose <> 0 Then
                WS.Cells(I, "F") = Mid(WS.Cells(I, "C"), ParClose + 2, Len(WS.Cells(I, "C")) - ParClose - 1)
            Else
                WS.Cells(I, "F") = WS.Cells(I, "C")
            End If
            Note = WS.Cells(I, "F")
            NoteItem = Split(Note, " ")
            Z = 0
            
            '---> Check to see if BACKRATIO is found then treat the sequence diffrently
            If InStr(1, WS.Cells(I, "F"), "BACKRATIO") <> 0 Then
                BkRatio = True
            Else
                BkRatio = False
            End If
            
            '---> Loop thru all items in the Note
            For K = 0 To UBound(NoteItem)
                '---> Remove any items that has open/close brakets as this is comment
                If Left(NoteItem(K), 1) = "(" Or Right(NoteItem(K), 1) = ")" Then
                    K = K + 1
                    Z = Z - 1
                End If
                
                '---> Remove any first letter / at first position
                If Left(NoteItem(K), 1) = "/" Then NoteItem(K) = Right(NoteItem(K), Len(NoteItem(K)) - 1)
                
                '---> Keep only VERTICAL/BUTTERFLY/STRANGLE/DIAGONAL in Second position
                If K = 2 Then
                    If UCase(NoteItem(K)) = "VERTICAL" Or _
                       UCase(NoteItem(K)) = "BUTTERFLY" Or _
                       UCase(NoteItem(K)) = "STRANGLE" Or _
                       UCase(NoteItem(K)) = "DIAGONAL" Then
                        Z = 0
                    Else
                        Z = 1
                    End If
                End If
                
                If BkRatio Then
                    '---> If BACKRATIO encountered then treat the sequence diffrently.
                    Select Case K
                    Case 0
                        WS.Cells(I, K + 7).NumberFormat = "@"
                        WS.Cells(I, K + 7) = Format(NoteItem(0), "@")
                    Case 1, 2
                        WS.Cells(I, 7 + 1).NumberFormat = "@"
                        WS.Cells(I, 7 + 1) = Format(NoteItem(1) & " " & NoteItem(2), "@")
                    Case Else
                        WS.Cells(I, K + 7 - 1).NumberFormat = "@"
                        WS.Cells(I, K + 7 - 1) = Format(NoteItem(K), "@")
                    End Select
                Else
                    
                    If InStr(1, Note, "@") <> 0 Then
                        '---> in any sequence is @ is encountered make sure it is positioned
                        '     in Col P as it is the Price Column the rest will follow.
                        If Left(NoteItem(K), 1) = "@" And K + 7 + Z <> 16 Then
                            Z = 16 - 7 - K
                        End If
                    Else
                        If K + 7 + Z = 16 Then
                            Z = 16 - 7 - K + 1
                        End If
                    End If
                    WS.Cells(I, K + 7 + Z).NumberFormat = "@"
                    WS.Cells(I, K + 7 + Z) = Format(NoteItem(K), "@")
                End If
            Next K
        End If
    Next j
Next I


'---> Loop Again thru all the notes in the Account Order History section
'     and match the columns where there is data to find the threads in sheet output
'     Columns in Sheet   G H I J K L M N  O  P  Q
'     Columns in Output  G H E I - [K] L  M  P  Q
'     Column Num Output  7   5 9    11 12 13 16 17
'     Columns to check   Y   Y Y    Y  Y  Y  Y  Y

For I = FMRow + 1 To TORow
    
    If WS.Cells(I, "F") <> "" Then
        wsopt.UsedRange.AutoFilter 1, Criteria1:=""
        If WS.Cells(I, "G") <> "" Then wsopt.UsedRange.AutoFilter 7, WS.Cells(I, "G")
        If WS.Cells(I, "I") <> "" Then wsopt.UsedRange.AutoFilter 5, WS.Cells(I, "I")
        If WS.Cells(I, "J") <> "" Then wsopt.UsedRange.AutoFilter 9, WS.Cells(I, "J")
        If WS.Cells(I, "L") <> "" Then
            If Len(WS.Cells(I, "L")) = 3 Then
                On Error Resume Next
                STMonth = DateSerial(WS.Cells(I, "M"), Month(DateValue(WS.Cells(I, "L") & " 1," & Year(Now))), 1)
                ENDMonth = DateSerial(Year(STMonth), Month(STMonth), Day(Application.WorksheetFunction.EoMonth(STMonth, 0)))
                wsopt.UsedRange.AutoFilter 11, Criteria1:=">=" & STMonth, Operator:=xlAnd, Criteria2:="<=" & ENDMonth
            Else
                On Error Resume Next
                STMonth = DateValue(Left(WS.Cells(I, "L"), 3) & " " & Right(WS.Cells(I, "L"), Len(WS.Cells(I, "L")) - 3) & "," & WS.Cells(I, "M"))
                wsopt.UsedRange.AutoFilter 11, Criteria1:=">=" & STMonth, Operator:=xlAnd, Criteria2:="<=" & STMonth
            End If
        End If
        On Error GoTo 0
        If WS.Cells(I, "N") <> "" And InStr(1, WS.Cells(I, "N"), "/") = 0 Then wsopt.UsedRange.AutoFilter 12, WS.Cells(I, "N")
        If WS.Cells(I, "O") <> "" And InStr(1, WS.Cells(I, "N"), "/") = 0 Then wsopt.UsedRange.AutoFilter 13, WS.Cells(I, "O")
        'If WS.Cells(I, "P") <> "" Then wsopt.UsedRange.AutoFilter 16, Criteria1:="<=" & Val(Right(WS.Cells(I, "P"), Len(WS.Cells(I, "P")) - 1))
        If WS.Cells(I, "Q") <> "" Then wsopt.UsedRange.AutoFilter 17, WS.Cells(I, "Q")
        NoteFound = NoteFound + 1
        FoundIT = True
        
        For Each Row In wsopt.Range("11:" & MaxRow).EntireRow.SpecialCells(xlCellTypeVisible).Rows
            If wsopt.Cells(Row.Row, "A").EntireRow.Hidden = False And wsopt.Cells(Row.Row, "C") <> "" And Row.Row <> 11 Then
                wsopt.Cells(Row.Row, "A") = WS.Cells(I, "F")
                RowMatched = RowMatched + 1
                FoundIT = False
                Exit For
            End If
        Next Row
        
        If FoundIT Then
            'MsgBox (WS.Cells(I, "F") & Chr(10) & "Was not mached in sheet Output !")
            WS.Cells(I, "F").Interior.ColorIndex = 3
            UnMatchedNotes = UnMatchedNotes + 1
        End If
        
        '---> Clear All Filters
        wsopt.UsedRange.AutoFilter 1
        wsopt.UsedRange.AutoFilter 5
        wsopt.UsedRange.AutoFilter 7
        wsopt.UsedRange.AutoFilter 9
        wsopt.UsedRange.AutoFilter 11
        wsopt.UsedRange.AutoFilter 12
        wsopt.UsedRange.AutoFilter 13
        wsopt.UsedRange.AutoFilter 16
        wsopt.UsedRange.AutoFilter 17
    End If
Next I

MsgBox ("A total of " & RowMatched & " Spread items were matched with notes." & Chr(10) _
& "A total of " & NoteFound & " Notes FILLED were found in the Order History Section." & Chr(10) _
& "A total of " & UnMatchedNotes & " Notes were not Matched in Sheet Output.")

End Sub
Private Sub Add_TotalRow_2_ExistingTable()
'Source adapted from:http://vbadud.blogspot.com/2008/07/add-total-row-to-excel-table-using-vba.html
Dim oWS As Worksheet ' Worksheet Object
Dim oRange As Range ' Range Object - Contains Represents the List of Items that need to be made unique
Dim oLst As ListObject ' List Object
Dim oLC As ListColumn ' List Column Object


On Error GoTo Disp_Error

Set oWS = ActiveSheet
If oWS.ListObjects.Count = 0 Then Exit Sub

Set oLst = oWS.ListObjects(1)
oLst.ShowTotals = True

' Change/Set the formatting of the Totals Row
oLst.TotalsRowRange.Font.Bold = True
'oLst.TotalsRowRange.Font.Color = vbRed


If Not oLC Is Nothing Then Set oLC = Nothing
If Not oLst Is Nothing Then Set oLst = Nothing
If Not oWS Is Nothing Then Set oWS = Nothing

' --------------------
' Error Handling
' --------------------
Disp_Error:
If Err <> 0 Then
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, "VBA Tips & Tricks Examples"
Resume Next
End If


End Sub

Open in new window

0
 
rtod2Author Commented:
gowflow, Thank you sir.

This is closer but not quite.  Here is a video illustration http://screencast.com/t/vUgIWwMPJ of the rule.

RULE:  If the 1st Leg of any Spread is a Buy then all of the Legs of the Spread are dark green and if the 1st Leg of any Spread is a Sell then all the Legs of the Spread are dark red.
0
 
rtod2Author Commented:
gowflow.  This is a bit off-topic with regard to the notes but since you are here, I wanted to mention it.

I am trying provide a clear explanation of what is needed to grab notes from the Live Trading (LT) data type and from the Paper Money (PM) data type.  I will be working on that description until I get it right and you can view what I am writing here >> https://docs.google.com/document/d/1NxszaU_d-FevAihblC3J2bYQht6kL4usCtnb4bOS7l8/edit?hl=en_US.  That is unrelated to the question in this thread but I wanted you to see it.
0
 
gowflowCommented:
Is this what you want ?
Here we are not taking care of the while lines in bteween groups !!! they are colored as well !
is this what you want or you still need to take care of the white lines ?(I mean the data that is there but with white font coloring !)
gowflow
'INTRODUCTION TO MACRO'

'!! Output tabs are created when the macro is run against a selected sheet in the Workbook.'

'1. This macro first looks to see which tab is selected and identifies a data type of rm or pm based'
'solely on the way the data appears within it.

'2. It then copies the data from the Trade History section of the original tab and creates a properly'
'formatted Output tab with a table for the that data where it continues to sort each Spread into'
'meaningful positions.'

'3. It then tries to also copy the notes from the original Order History section into the appropriate'
'cell for each Spread.'

'4. Just like with creating the table, the notes rely heavily on determining whether the originating'
'data type is rm or pm.'

'5. It then cleans the output providing correctly alligned data and returns the focus to A1.

'6. Future development will include making some calculations on each overall position.'

Option Explicit

Const AOH = "Account Order History"
Const ATH = "Account Trade History"
Const PAL = "Profits and Losses"
Const EQT = "Equities"
Const OPT = "Options"
Const OTH = "Others"
Const FRX = "Forex"

Dim wsopt As Worksheet
    

Private Sub AddMOColumn()
'This Sub will Add A new Column before Exp Column J that should indicate either of the following
'M for Monthly when the date in Exp is formated as Mmm-yy the date should be the 3rd friday of the month
'O for Weekly or Quarterly options


Dim MaxRow As Long, I As Long
Dim dDate As Date
Dim ThirdThuOfTheMonth As Date
Dim a

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row
wsopt.Select
Columns("J:J").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("J11") = "OT"

For I = 12 To MaxRow
    If wsopt.Cells(I, "K") <> "" Then
        If wsopt.Cells(I, "K").NumberFormat = "mmm-dd-yy" Then
            wsopt.Cells(I, "J") = "O"
        Else
            wsopt.Cells(I, "J") = "M"
            dDate = wsopt.Cells(I, "K")
            dDate = DateSerial(Year(dDate), Month(dDate), 1)
            Select Case Weekday(dDate)
                Case 5  'If Date is a Thursday then add 14 days
                    ThirdThuOfTheMonth = DateValue(dDate + 14)
                Case Is > 5 'If Date is Friday or saturday then add 21+1 days
                    ThirdThuOfTheMonth = DateValue(dDate + 21 - (Weekday(dDate) - vbThursday))
                Case Is < 5 'If Date is Sunday to Thurthday then add 14+ diffrence to friday days
                    ThirdThuOfTheMonth = DateValue(dDate + 14 + vbThursday - Weekday(dDate))
            End Select
            If Weekday(ThirdThuOfTheMonth) <> vbThursday Then
                MsgBox ("this date: " & ThirdThuOfTheMonth & " does not corespond to a Thursday! on row " & I & " Please check that date in Col K is actually a valid date then re-run the whole macro.")
            End If
            wsopt.Cells(I, "K") = ThirdThuOfTheMonth
        End If
    End If
Next I
End Sub

Private Sub AddDaysandPLColumn()
'This Sub will Add 3 new Columns
'Days to Exp in Col N next to type Column which should be the diffrence in days between Exec Time and Exp
'P/L Balance Col R
'P/L% Col S


Dim MaxRow As Long, I As Long
Dim dDate As Date
Dim ThirdThuOfTheMonth As Date
Dim a

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row
wsopt.Select
Columns("N:N").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("N11") = "Days to Exp"
Columns("R:S").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("R11") = "P/L Balance"
wsopt.Range("S11") = "P/L %"


For I = 12 To MaxRow
    If wsopt.Cells(I, "K") <> "" Then
        wsopt.Cells(I, "N") = DateValue(wsopt.Cells(I, "C")) - DateValue(wsopt.Cells(I, "K"))
    End If
    
    
Next I
End Sub


Private Sub Coloring()
'This Sub will go color threads
'The header row should be black with white lettering
'1. Dark Green if the first Leg of the Spread is a Buy.
'2. Dark Red if the first Leg of the Spread is a Sell.


Dim MaxRow As Long, I As Long, j As Long, PrevSpread As Long
Dim tmpM As String, tmpD As String, tmpY As String
Dim SELL As Boolean

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row

wsopt.Range("A11:S11").Interior.ColorIndex = 1

For I = 12 To MaxRow
    If wsopt.Cells(I, "D") <> PrevSpread Then
        If wsopt.Cells(I, "G") = "SELL" Then
            SELL = True
        Else
            SELL = False
        End If
    End If
    'If wsopt.Cells(I, "B").Font.ColorIndex <> 2 Then
        If SELL Then
            wsopt.Range(wsopt.Cells(I, "A"), wsopt.Cells(I, "S")).Font.ColorIndex = 6
            wsopt.Range(wsopt.Cells(I, "A"), wsopt.Cells(I, "S")).Interior.ColorIndex = 9
        Else
            wsopt.Range(wsopt.Cells(I, "A"), wsopt.Cells(I, "S")).Font.ColorIndex = 6
            wsopt.Range(wsopt.Cells(I, "A"), wsopt.Cells(I, "S")).Interior.ColorIndex = 10
        End If
        PrevSpread = wsopt.Cells(I, "D")
    'End If

Next I
wsopt.Range(wsopt.Cells(MaxRow + 1, "A"), wsopt.Cells(MaxRow + 1, "S")).Interior.ColorIndex = 1

End Sub

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
    Dim FirstAddress As String
    
    On Error GoTo Whoa
    
    Application.ScreenUpdating = True
    
    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
        
        If LCase(Left(shName, 2)) = "pm" Then
            '--> Find the "Options" cell in Sheet PM'
            Set bCell = wsPM.Columns(1).Find(what:=OPT, LookIn:=xlFormulas, _
            lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        
            If bCell Is Nothing Then
            '--> Find the "Forex" cell in Sheet PM if Options is not found'
                Set bCell = wsPM.Columns(1).Find(what:=FRX, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
            
            If bCell Is Nothing Then
            '--> Find the "Profits and Losses" cell in Sheet PM if Forex is not found'
                Set bCell = wsPM.Columns(1).Find(what:=PAL, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
        End If
        
        If LCase(Left(shName, 2)) = "rm" Then
            '--> Find the "Equities" cell in Sheet RM'
            Set bCell = wsPM.Columns(1).Find(what:=EQT, LookIn:=xlFormulas, _
            lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
            
            If bCell Is Nothing Then
            '--> Find the "Others" cell in Sheet RM if Equities is not found
                Set bCell = wsPM.Columns(1).Find(what:=OTH, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
        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 LCase(Left(shName, 2)) = "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.
                    wsPM.Range("IV:IV").ClearContents
                    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
                            wsPM.Range("IV" & I).Value = SearchString
                    Next I
                
                    For j = 2 To lastRow
                        MatchString = .Range("D" & j).Value & "###" & _
                                        .Range("F" & j).Value & "###" & _
                                        .Range("G" & j).Value & "###" & _
                                        .Range("H" & j).Value & "###" & _
                                        .Range("I" & j).Value
                
                            Set cCell = wsPM.Range("IV:IV").Find(what:=MatchString, LookIn:=xlFormulas, _
                                        lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                        MatchCase:=False, SearchFormat:=False)
                            If Not cCell Is Nothing Then
                                FirstAddress = cCell.Address
                                    Do
                                        If wsopt.Range("F" & j).Value = wsPM.Range("F" & cCell.Row).Value Then
                                            .Range("A" & j).Value = wsPM.Range("A" & cCell.Row).Value
                                            Exit Do
                                        Else
                                            Set cCell = wsPM.Range("IV:IV").FindNext(cCell)
                                        End If
                                    Loop While Not cCell Is Nothing And cCell.Address <> FirstAddress
                            End If
                    Next j
                End If
                GoTo There

                '--> Copy the notes into the new notes column. old'
                    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
                
There:
                '--> 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
    FixDate
    Indexing
    Sorting
    AddMOColumn
    AddDaysandPLColumn
    If LCase(Left(shName, 2)) = "rm" Then
        UpdateNotes wsPM, AOHRow, ATHRow
    End If
    Coloring
    
    wsopt.Cells(1, 1).Select

    Call cleanOutput
    
    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 cleanOutput()
Dim r As Range, rng As Range
Dim lastRow As Long
Dim cntAddr As String

    'assumes output tab just generated and thus doesn't have total row already, etc., as it had been previously cleared...
    
    'Freeze panes on the first 11 rows so that the header row will always be visible when scrolling.

    ThisWorkbook.Activate 'just in case another workbook is on top

    wsopt.Activate 'just in case another worksheet is in focus
    wsopt.Range("12:12").Select
    ActiveWindow.FreezePanes = False
    ActiveWindow.FreezePanes = True
    
    'Shorten the name of the Order Type column to just Order.
    
    wsopt.Range("Q11").Value = "Order"
    
    'Rename the OT column to say Period and the data in it where M becomes Monthly spelled out, and O becomes Other spelled out.
    
    wsopt.Range("J11").Value = "Period"
    
    lastRow = wsopt.Range("A" & wsopt.Rows.Count).End(xlUp).Row
    Set r = wsopt.Range(wsopt.Range("J12"), wsopt.Cells(lastRow, "J"))
    
    'in case none found, turn on error trap
    On Error Resume Next
    r.Replace what:="M", replacement:="Monthly", lookAt:=xlWhole
    r.Replace what:="O", replacement:="Other", lookAt:=xlWhole
    On Error GoTo 0
    
    'Left justify the data in all columns except for P#, S#, L#, Qty, Strike, Days which should be centered.
    
'MOST DATA CENTERED - However, all the remaining data columns themselves with the exception of Qty should be centered. This will improve readability a great deal. Qty is different though because of the minus (-) sign. My thinking is that it should be right justified with a 2 space offset to give the illusion that it is centered also but still take into account the minus (-) sign in front of some of the numbers.
       
    Set r = wsopt.Range(wsopt.Range("B12"), wsopt.Cells(lastRow, "S"))
    With r
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    
    'now make Notes left justified
    Set r = wsopt.Range("A12:A" & lastRow)
    With r
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
    End With
    
    'and O, P, R & S should be right justified
    Set r = Union(wsopt.Range("O12:O" & lastRow), wsopt.Range("P12:P" & lastRow), wsopt.Range("R12:R" & lastRow), wsopt.Range("S12:S" & lastRow))
    With r
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
    End With
    
    'format Qty so numbers without negatives are one space over
    Set r = wsopt.Range("H12:H" & lastRow)
    r.NumberFormat = "[<0]-0;+0"
    
    Set r = wsopt.Range("N12:N" & lastRow)
    r.NumberFormat = "[<0]0;0"
    
    
    'Add a Total Row at the bottom that simply displays a count for the number notes that are filled in for that column, and leaves every other total empty.
    Call Add_TotalRow_2_ExistingTable
    cntAddr = wsopt.Range(wsopt.Cells(12, 1), wsopt.Cells(lastRow, 1)).Address
    wsopt.Range("A" & lastRow + 1).Formula = "=COUNTA(" & cntAddr & ")"

    
'COMPLETE HEADINGS - Adjust macro to replace column headings in the resulting Output tab for P#, S#, and L# and instead use headings Pos#, Spread# and Leg#.
    wsopt.Range("B11").Value = "Pos#"
    wsopt.Range("D11").Value = "Spread#"
    wsopt.Range("F11").Value = "Leg#"
'HEADER LEFT - A reconsideration of the formatting rules leads me to believe that the header row of the resulting Output tab as well as the data in the Notes column should still be left justified.
    With wsopt.Range("A11:S11")
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
    End With
   
    'Auto-fit all columns to width of data with the exception of the Notes column.
    wsopt.Range("B:S").EntireColumn.AutoFit
        
    'Always return focus to cell A1.
    wsopt.Range("A1").Select
    ActiveWindow.ScrollRow = 1
    ActiveWindow.ScrollColumn = 1

End Sub
Private Sub FixDate()
'This Sub will go thru Exp Column Col J and will Fix the date to allow for either mm-yy or mmm-dd-yy.

Dim MaxRow As Long, I As Long
Dim tmpM As String, tmpD As String, tmpY As String

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row

For I = 12 To MaxRow
    '---> Strip Dates and Fix them
    If wsopt.Cells(I, "J") <> "" Then
        If IsDate(wsopt.Cells(I, "J")) Then
            '---> Format normally if normal Date format as 'mmm-dd-yy'
            wsopt.Cells(I, "J").NumberFormat = "Mmm-yy"
        Else
            '---> Strip the date in Day month Year then re-group so system would recognize
            '     it as a date and then apply format 'mmm-yy'
            tmpM = Left(wsopt.Cells(I, "J"), 3)
            tmpY = Right(wsopt.Cells(I, "J"), 2)
            tmpD = Mid(wsopt.Cells(I, "J"), 4, Len(wsopt.Cells(I, "J")) - 6)
            wsopt.Cells(I, "J") = tmpM & " " & Format(Val(tmpD), "") & ", " & Format(Val(tmpY), "")
            wsopt.Cells(I, "J").NumberFormat = "Mmm-dd-yy"
        End If
    End If

Next I

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
ActiveSheet.PageSetup.PrintArea = ""
wsopt.PageSetup.FitToPagesWide = 1
wsopt.PageSetup.FitToPagesTall = 1

End Sub

'DEFINITIONS - Definitions to understand prior to Indexing and Ordering'
'1. Positions - Positions can be made up of more than one Spread and the newest Positions appear at the top of the sheet.'
'2. Spreads - Spreads can be made up of more than one Leg and their order with a position can change.'
'3. Legs - Legs are made up of individual rows within a Spread and there order within the spread never changes.'

'It is important to note that spreads always belong together in the same position if any of its legs
'contain the same Symbol Exp Strike, and Type of any other spread within the sheet.'

Private Sub Indexing()
'Each Position, Spread, and Leg is indexed with a number according to the value in its Exec Date column.'
'P# - Positions are numbered sequentially with 1 being  meaning that it contains a newer Exec Date than any other positions.'
'S# - Spreads are numbered sequentially with 1 meaning that it contains the a newer Exec Date than the other spreads.'
'L# - 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 alphabetical order.'

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()

'Positions can contain single or multi-legged spreads but the sort order of the legs 'within' each'
'spread never changes. This is an important point because by contrast, the sort order in which each
'spread appears within the overall position does indeed change. Here the oldest spreads should'
'appear at the top of the position while newer spreads should appear at the bottom of the position.'

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 wsopt.Range("B" & I) <> wsopt.Range("B" & I - 1) And wsopt.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
wsopt.Sort.SortFields.Add Key:=wsopt.Range("C11"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

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
        
         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.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

Sub UpdateNotes(WS As Worksheet, FMRow As Long, TORow As Long)
'This Sub will update noted for rm sheets from the Account Order History section in Col A
'To match with data in the Output file created under wsopt variable.

Dim MaxRow As Long, I As Long, j As Long, K As Long, Z As Long
Dim Note As String
Dim NoteItem
Dim Row As Range
Dim Status
Dim ParClose As Long, RowMatched As Long, UnMatchedNotes As Long, NoteFound As Long
Dim BkRatio As Boolean, FoundIT As Boolean
Dim STMonth As Date, ENDMonth As Date


MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row

'---> Clean the Area F to Z to dissec Notes
WS.Range("F" & FMRow & ":ZZ" & TORow).ClearContents
WS.Range("F" & FMRow & ":ZZ" & TORow).ClearFormats


'---> Clean the notes and copy to Col F only for Status Filled Notes
For I = FMRow + 1 To TORow
    Status = Split(WS.Cells(I, "D"), " ")
    For j = 0 To UBound(Status)
        If UCase(Status(j)) = "FILLED" Then
            '---> If a note start with (Replacing ... then remove the first part till the first space
            If Left(WS.Cells(I, "C"), 10) = "(Replacing" Then
                ParClose = InStr(1, WS.Cells(I, "C"), ")")
            Else
                ParClose = 0
            End If
            
            If ParClose <> 0 Then
                WS.Cells(I, "F") = Mid(WS.Cells(I, "C"), ParClose + 2, Len(WS.Cells(I, "C")) - ParClose - 1)
            Else
                WS.Cells(I, "F") = WS.Cells(I, "C")
            End If
            Note = WS.Cells(I, "F")
            NoteItem = Split(Note, " ")
            Z = 0
            
            '---> Check to see if BACKRATIO is found then treat the sequence diffrently
            If InStr(1, WS.Cells(I, "F"), "BACKRATIO") <> 0 Then
                BkRatio = True
            Else
                BkRatio = False
            End If
            
            '---> Loop thru all items in the Note
            For K = 0 To UBound(NoteItem)
                '---> Remove any items that has open/close brakets as this is comment
                If Left(NoteItem(K), 1) = "(" Or Right(NoteItem(K), 1) = ")" Then
                    K = K + 1
                    Z = Z - 1
                End If
                
                '---> Remove any first letter / at first position
                If Left(NoteItem(K), 1) = "/" Then NoteItem(K) = Right(NoteItem(K), Len(NoteItem(K)) - 1)
                
                '---> Keep only VERTICAL/BUTTERFLY/STRANGLE/DIAGONAL in Second position
                If K = 2 Then
                    If UCase(NoteItem(K)) = "VERTICAL" Or _
                       UCase(NoteItem(K)) = "BUTTERFLY" Or _
                       UCase(NoteItem(K)) = "STRANGLE" Or _
                       UCase(NoteItem(K)) = "DIAGONAL" Then
                        Z = 0
                    Else
                        Z = 1
                    End If
                End If
                
                If BkRatio Then
                    '---> If BACKRATIO encountered then treat the sequence diffrently.
                    Select Case K
                    Case 0
                        WS.Cells(I, K + 7).NumberFormat = "@"
                        WS.Cells(I, K + 7) = Format(NoteItem(0), "@")
                    Case 1, 2
                        WS.Cells(I, 7 + 1).NumberFormat = "@"
                        WS.Cells(I, 7 + 1) = Format(NoteItem(1) & " " & NoteItem(2), "@")
                    Case Else
                        WS.Cells(I, K + 7 - 1).NumberFormat = "@"
                        WS.Cells(I, K + 7 - 1) = Format(NoteItem(K), "@")
                    End Select
                Else
                    
                    If InStr(1, Note, "@") <> 0 Then
                        '---> in any sequence is @ is encountered make sure it is positioned
                        '     in Col P as it is the Price Column the rest will follow.
                        If Left(NoteItem(K), 1) = "@" And K + 7 + Z <> 16 Then
                            Z = 16 - 7 - K
                        End If
                    Else
                        If K + 7 + Z = 16 Then
                            Z = 16 - 7 - K + 1
                        End If
                    End If
                    WS.Cells(I, K + 7 + Z).NumberFormat = "@"
                    WS.Cells(I, K + 7 + Z) = Format(NoteItem(K), "@")
                End If
            Next K
        End If
    Next j
Next I


'---> Loop Again thru all the notes in the Account Order History section
'     and match the columns where there is data to find the threads in sheet output
'     Columns in Sheet   G H I J K L M N  O  P  Q
'     Columns in Output  G H E I - [K] L  M  P  Q
'     Column Num Output  7   5 9    11 12 13 16 17
'     Columns to check   Y   Y Y    Y  Y  Y  Y  Y

For I = FMRow + 1 To TORow
    
    If WS.Cells(I, "F") <> "" Then
        wsopt.UsedRange.AutoFilter 1, Criteria1:=""
        If WS.Cells(I, "G") <> "" Then wsopt.UsedRange.AutoFilter 7, WS.Cells(I, "G")
        If WS.Cells(I, "I") <> "" Then wsopt.UsedRange.AutoFilter 5, WS.Cells(I, "I")
        If WS.Cells(I, "J") <> "" Then wsopt.UsedRange.AutoFilter 9, WS.Cells(I, "J")
        If WS.Cells(I, "L") <> "" Then
            If Len(WS.Cells(I, "L")) = 3 Then
                On Error Resume Next
                STMonth = DateSerial(WS.Cells(I, "M"), Month(DateValue(WS.Cells(I, "L") & " 1," & Year(Now))), 1)
                ENDMonth = DateSerial(Year(STMonth), Month(STMonth), Day(Application.WorksheetFunction.EoMonth(STMonth, 0)))
                wsopt.UsedRange.AutoFilter 11, Criteria1:=">=" & STMonth, Operator:=xlAnd, Criteria2:="<=" & ENDMonth
            Else
                On Error Resume Next
                STMonth = DateValue(Left(WS.Cells(I, "L"), 3) & " " & Right(WS.Cells(I, "L"), Len(WS.Cells(I, "L")) - 3) & "," & WS.Cells(I, "M"))
                wsopt.UsedRange.AutoFilter 11, Criteria1:=">=" & STMonth, Operator:=xlAnd, Criteria2:="<=" & STMonth
            End If
        End If
        On Error GoTo 0
        If WS.Cells(I, "N") <> "" And InStr(1, WS.Cells(I, "N"), "/") = 0 Then wsopt.UsedRange.AutoFilter 12, WS.Cells(I, "N")
        If WS.Cells(I, "O") <> "" And InStr(1, WS.Cells(I, "N"), "/") = 0 Then wsopt.UsedRange.AutoFilter 13, WS.Cells(I, "O")
        'If WS.Cells(I, "P") <> "" Then wsopt.UsedRange.AutoFilter 16, Criteria1:="<=" & Val(Right(WS.Cells(I, "P"), Len(WS.Cells(I, "P")) - 1))
        If WS.Cells(I, "Q") <> "" Then wsopt.UsedRange.AutoFilter 17, WS.Cells(I, "Q")
        NoteFound = NoteFound + 1
        FoundIT = True
        
        For Each Row In wsopt.Range("11:" & MaxRow).EntireRow.SpecialCells(xlCellTypeVisible).Rows
            If wsopt.Cells(Row.Row, "A").EntireRow.Hidden = False And wsopt.Cells(Row.Row, "C") <> "" And Row.Row <> 11 Then
                wsopt.Cells(Row.Row, "A") = WS.Cells(I, "F")
                RowMatched = RowMatched + 1
                FoundIT = False
                Exit For
            End If
        Next Row
        
        If FoundIT Then
            'MsgBox (WS.Cells(I, "F") & Chr(10) & "Was not mached in sheet Output !")
            WS.Cells(I, "F").Interior.ColorIndex = 3
            UnMatchedNotes = UnMatchedNotes + 1
        End If
        
        '---> Clear All Filters
        wsopt.UsedRange.AutoFilter 1
        wsopt.UsedRange.AutoFilter 5
        wsopt.UsedRange.AutoFilter 7
        wsopt.UsedRange.AutoFilter 9
        wsopt.UsedRange.AutoFilter 11
        wsopt.UsedRange.AutoFilter 12
        wsopt.UsedRange.AutoFilter 13
        wsopt.UsedRange.AutoFilter 16
        wsopt.UsedRange.AutoFilter 17
    End If
Next I

MsgBox ("A total of " & RowMatched & " Spread items were matched with notes." & Chr(10) _
& "A total of " & NoteFound & " Notes FILLED were found in the Order History Section." & Chr(10) _
& "A total of " & UnMatchedNotes & " Notes were not Matched in Sheet Output.")

End Sub
Private Sub Add_TotalRow_2_ExistingTable()
'Source adapted from:http://vbadud.blogspot.com/2008/07/add-total-row-to-excel-table-using-vba.html
Dim oWS As Worksheet ' Worksheet Object
Dim oRange As Range ' Range Object - Contains Represents the List of Items that need to be made unique
Dim oLst As ListObject ' List Object
Dim oLC As ListColumn ' List Column Object


On Error GoTo Disp_Error

Set oWS = ActiveSheet
If oWS.ListObjects.Count = 0 Then Exit Sub

Set oLst = oWS.ListObjects(1)
oLst.ShowTotals = True

' Change/Set the formatting of the Totals Row
oLst.TotalsRowRange.Font.Bold = True
'oLst.TotalsRowRange.Font.Color = vbRed


If Not oLC Is Nothing Then Set oLC = Nothing
If Not oLst Is Nothing Then Set oLst = Nothing
If Not oWS Is Nothing Then Set oWS = Nothing

' --------------------
' Error Handling
' --------------------
Disp_Error:
If Err <> 0 Then
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, "VBA Tips & Tricks Examples"
Resume Next
End If


End Sub

Open in new window

0
 
rtod2Author Commented:
Gowflow thank you,
It should not remove the white lines.  The white lines are there because one of the requirements is that the filtering of the sheet not disturb the overall position. That is to say that there is a line between each position to differentiate them from each other. I was never able to get clarification as to why the white lines needed to have data in them but the fact that there does seem to be data in them has always been troubling to me. My original intent was to simply have a way to differentiate each position from each other.  You may note that each position has a unique number identifying it and each spread also has this.
0
 
dlmilleCommented:
Looks like goflow has you covered.

Cheers,

Dave
0
 
dlmilleCommented:
Ok = I watched your video.  Appears I misunderstood because a prior video you dismissed SINGLE spreads, so as a result of prior video, I purposefully checked for spreads of > 1 row and marked ONLY them.

However, I see you want ALL spreads marked.  Easy enough.  I just tested and looks like it is as you expected in your last video.

Here's the code:
 
'INTRODUCTION TO MACRO'

'!! Output tabs are created when the macro is run against a selected sheet in the Workbook.'

'1. This macro first looks to see which tab is selected and identifies a data type of rm or pm based'
'solely on the way the data appears within it.

'2. It then copies the data from the Trade History section of the original tab and creates a properly'
'formatted Output tab with a table for the that data where it continues to sort each Spread into'
'meaningful positions.'

'3. It then tries to also copy the notes from the original Order History section into the appropriate'
'cell for each Spread.'

'4. Just like with creating the table, the notes rely heavily on determining whether the originating'
'data type is rm or pm.'

'5. It then cleans the output providing correctly alligned data and returns the focus to A1.

'6. Future development will include making some calculations on each overall position.'

Option Explicit

Const AOH = "Account Order History"
Const ATH = "Account Trade History"
Const PAL = "Profits and Losses"
Const EQT = "Equities"
Const OPT = "Options"
Const OTH = "Others"
Const FRX = "Forex"

Dim wsopt As Worksheet
    

Private Sub AddMOColumn()
'This Sub will Add A new Column before Exp Column J that should indicate either of the following
'M for Monthly when the date in Exp is formated as Mmm-yy the date should be the 3rd friday of the month
'O for Weekly or Quarterly options


Dim MaxRow As Long, I As Long
Dim dDate As Date
Dim ThirdThuOfTheMonth As Date
Dim a

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row
wsopt.Select
Columns("J:J").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("J11") = "OT"

For I = 12 To MaxRow
    If wsopt.Cells(I, "K") <> "" Then
        If wsopt.Cells(I, "K").NumberFormat = "mmm-dd-yy" Then
            wsopt.Cells(I, "J") = "O"
        Else
            wsopt.Cells(I, "J") = "M"
            dDate = wsopt.Cells(I, "K")
            dDate = DateSerial(Year(dDate), Month(dDate), 1)
            Select Case Weekday(dDate)
                Case 5  'If Date is a Thursday then add 14 days
                    ThirdThuOfTheMonth = DateValue(dDate + 14)
                Case Is > 5 'If Date is Friday or saturday then add 21+1 days
                    ThirdThuOfTheMonth = DateValue(dDate + 21 - (Weekday(dDate) - vbThursday))
                Case Is < 5 'If Date is Sunday to Thurthday then add 14+ diffrence to friday days
                    ThirdThuOfTheMonth = DateValue(dDate + 14 + vbThursday - Weekday(dDate))
            End Select
            If Weekday(ThirdThuOfTheMonth) <> vbThursday Then
                MsgBox ("this date: " & ThirdThuOfTheMonth & " does not corespond to a Thursday! on row " & I & " Please check that date in Col K is actually a valid date then re-run the whole macro.")
            End If
            wsopt.Cells(I, "K") = ThirdThuOfTheMonth
        End If
    End If
Next I
End Sub

Private Sub AddDaysandPLColumn()
'This Sub will Add 3 new Columns
'Days to Exp in Col N next to type Column which should be the diffrence in days between Exec Time and Exp
'P/L Balance Col R
'P/L% Col S


Dim MaxRow As Long, I As Long
Dim dDate As Date
Dim ThirdThuOfTheMonth As Date
Dim a

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row
wsopt.Select
Columns("N:N").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("N11") = "Days to Exp"
Columns("R:S").Select
Selection.Insert Shift:=xlToRight
wsopt.Range("R11") = "P/L Balance"
wsopt.Range("S11") = "P/L %"


For I = 12 To MaxRow
    If wsopt.Cells(I, "K") <> "" Then
        wsopt.Cells(I, "N") = DateValue(wsopt.Cells(I, "C")) - DateValue(wsopt.Cells(I, "K"))
    End If
    
    
Next I
End Sub


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
    Dim FirstAddress As String
    
    On Error GoTo Whoa
    
    Application.ScreenUpdating = True
    
    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
        
        If LCase(Left(shName, 2)) = "pm" Then
            '--> Find the "Options" cell in Sheet PM'
            Set bCell = wsPM.Columns(1).Find(what:=OPT, LookIn:=xlFormulas, _
            lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        
            If bCell Is Nothing Then
            '--> Find the "Forex" cell in Sheet PM if Options is not found'
                Set bCell = wsPM.Columns(1).Find(what:=FRX, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
            
            If bCell Is Nothing Then
            '--> Find the "Profits and Losses" cell in Sheet PM if Forex is not found'
                Set bCell = wsPM.Columns(1).Find(what:=PAL, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
        End If
        
        If LCase(Left(shName, 2)) = "rm" Then
            '--> Find the "Equities" cell in Sheet RM'
            Set bCell = wsPM.Columns(1).Find(what:=EQT, LookIn:=xlFormulas, _
            lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
            
            If bCell Is Nothing Then
            '--> Find the "Others" cell in Sheet RM if Equities is not found
                Set bCell = wsPM.Columns(1).Find(what:=OTH, LookIn:=xlFormulas, _
                lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
            End If
        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 LCase(Left(shName, 2)) = "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.
                    wsPM.Range("IV:IV").ClearContents
                    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
                            wsPM.Range("IV" & I).Value = SearchString
                    Next I
                
                    For J = 2 To lastRow
                        MatchString = .Range("D" & J).Value & "###" & _
                                        .Range("F" & J).Value & "###" & _
                                        .Range("G" & J).Value & "###" & _
                                        .Range("H" & J).Value & "###" & _
                                        .Range("I" & J).Value
                
                            Set cCell = wsPM.Range("IV:IV").Find(what:=MatchString, LookIn:=xlFormulas, _
                                        lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                        MatchCase:=False, SearchFormat:=False)
                            If Not cCell Is Nothing Then
                                FirstAddress = cCell.Address
                                    Do
                                        If wsopt.Range("F" & J).Value = wsPM.Range("F" & cCell.Row).Value Then
                                            .Range("A" & J).Value = wsPM.Range("A" & cCell.Row).Value
                                            Exit Do
                                        Else
                                            Set cCell = wsPM.Range("IV:IV").FindNext(cCell)
                                        End If
                                    Loop While Not cCell Is Nothing And cCell.Address <> FirstAddress
                            End If
                    Next J
                End If
                GoTo There

                '--> Copy the notes into the new notes column. old'
                    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
                
There:
                '--> 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
    FixDate
    Indexing
    Sorting
    AddMOColumn
    AddDaysandPLColumn
    If LCase(Left(shName, 2)) = "rm" Then
        UpdateNotes wsPM, AOHRow, ATHRow
    End If
    
    wsopt.Cells(1, 1).Select

    Call cleanOutput
    
    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 FixDate()
'This Sub will go thru Exp Column Col J and will Fix the date to allow for either mm-yy or mmm-dd-yy.

Dim MaxRow As Long, I As Long
Dim tmpM As String, tmpD As String, tmpY As String

MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row

For I = 12 To MaxRow
    '---> Strip Dates and Fix them
    If wsopt.Cells(I, "J") <> "" Then
        If IsDate(wsopt.Cells(I, "J")) Then
            '---> Format normally if normal Date format as 'mmm-dd-yy'
            wsopt.Cells(I, "J").NumberFormat = "Mmm-yy"
        Else
            '---> Strip the date in Day month Year then re-group so system would recognize
            '     it as a date and then apply format 'mmm-yy'
            tmpM = Left(wsopt.Cells(I, "J"), 3)
            tmpY = Right(wsopt.Cells(I, "J"), 2)
            tmpD = Mid(wsopt.Cells(I, "J"), 4, Len(wsopt.Cells(I, "J")) - 6)
            wsopt.Cells(I, "J") = tmpM & " " & Format(Val(tmpD), "") & ", " & Format(Val(tmpY), "")
            wsopt.Cells(I, "J").NumberFormat = "Mmm-dd-yy"
        End If
    End If

Next I

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
ActiveSheet.PageSetup.PrintArea = ""
wsopt.PageSetup.FitToPagesWide = 1
wsopt.PageSetup.FitToPagesTall = 1

End Sub

'DEFINITIONS - Definitions to understand prior to Indexing and Ordering'
'1. Positions - Positions can be made up of more than one Spread and the newest Positions appear at the top of the sheet.'
'2. Spreads - Spreads can be made up of more than one Leg and their order with a position can change.'
'3. Legs - Legs are made up of individual rows within a Spread and there order within the spread never changes.'

'It is important to note that spreads always belong together in the same position if any of its legs
'contain the same Symbol Exp Strike, and Type of any other spread within the sheet.'

Private Sub Indexing()
'Each Position, Spread, and Leg is indexed with a number according to the value in its Exec Date column.'
'P# - Positions are numbered sequentially with 1 being  meaning that it contains a newer Exec Date than any other positions.'
'S# - Spreads are numbered sequentially with 1 meaning that it contains the a newer Exec Date than the other spreads.'
'L# - 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 alphabetical order.'

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)
    'dlmille no grey - 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()

'Positions can contain single or multi-legged spreads but the sort order of the legs 'within' each'
'spread never changes. This is an important point because by contrast, the sort order in which each
'spread appears within the overall position does indeed change. Here the oldest spreads should'
'appear at the top of the position while newer spreads should appear at the bottom of the position.'

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 wsopt.Range("B" & I) <> wsopt.Range("B" & I - 1) And wsopt.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
wsopt.Sort.SortFields.Add Key:=wsopt.Range("C11"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

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
        
         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.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
    'dlmille no grey - 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

Sub UpdateNotes(WS As Worksheet, FMRow As Long, TORow As Long)
'This Sub will update noted for rm sheets from the Account Order History section in Col A
'To match with data in the Output file created under wsopt variable.

Dim MaxRow As Long, I As Long, J As Long, K As Long, Z As Long
Dim Note As String
Dim NoteItem
Dim Row As Range
Dim Status
Dim ParClose As Long, RowMatched As Long, UnMatchedNotes As Long, NoteFound As Long
Dim BkRatio As Boolean, FoundIT As Boolean
Dim STMonth As Date, ENDMonth As Date


MaxRow = wsopt.Rows(wsopt.Rows.Count).End(xlUp).Row

'---> Clean the Area F to Z to dissec Notes
WS.Range("F" & FMRow & ":ZZ" & TORow).ClearContents
WS.Range("F" & FMRow & ":ZZ" & TORow).ClearFormats


'---> Clean the notes and copy to Col F only for Status Filled Notes
For I = FMRow + 1 To TORow
    Status = Split(WS.Cells(I, "D"), " ")
    For J = 0 To UBound(Status)
        If UCase(Status(J)) = "FILLED" Then
            '---> If a note start with (Replacing ... then remove the first part till the first space
            If Left(WS.Cells(I, "C"), 10) = "(Replacing" Then
                ParClose = InStr(1, WS.Cells(I, "C"), ")")
            Else
                ParClose = 0
            End If
            
            If ParClose <> 0 Then
                WS.Cells(I, "F") = Mid(WS.Cells(I, "C"), ParClose + 2, Len(WS.Cells(I, "C")) - ParClose - 1)
            Else
                WS.Cells(I, "F") = WS.Cells(I, "C")
            End If
            Note = WS.Cells(I, "F")
            NoteItem = Split(Note, " ")
            Z = 0
            
            '---> Check to see if BACKRATIO is found then treat the sequence diffrently
            If InStr(1, WS.Cells(I, "F"), "BACKRATIO") <> 0 Then
                BkRatio = True
            Else
                BkRatio = False
            End If
            
            '---> Loop thru all items in the Note
            For K = 0 To UBound(NoteItem)
                '---> Remove any items that has open/close brakets as this is comment
                If Left(NoteItem(K), 1) = "(" Or Right(NoteItem(K), 1) = ")" Then
                    K = K + 1
                    Z = Z - 1
                End If
                
                '---> Remove any first letter / at first position
                If Left(NoteItem(K), 1) = "/" Then NoteItem(K) = Right(NoteItem(K), Len(NoteItem(K)) - 1)
                
                '---> Keep only VERTICAL/BUTTERFLY/STRANGLE/DIAGONAL in Second position
                If K = 2 Then
                    If UCase(NoteItem(K)) = "VERTICAL" Or _
                       UCase(NoteItem(K)) = "BUTTERFLY" Or _
                       UCase(NoteItem(K)) = "STRANGLE" Or _
                       UCase(NoteItem(K)) = "DIAGONAL" Then
                        Z = 0
                    Else
                        Z = 1
                    End If
                End If
                
                If BkRatio Then
                    '---> If BACKRATIO encountered then treat the sequence diffrently.
                    Select Case K
                    Case 0
                        WS.Cells(I, K + 7).NumberFormat = "@"
                        WS.Cells(I, K + 7) = Format(NoteItem(0), "@")
                    Case 1, 2
                        WS.Cells(I, 7 + 1).NumberFormat = "@"
                        WS.Cells(I, 7 + 1) = Format(NoteItem(1) & " " & NoteItem(2), "@")
                    Case Else
                        WS.Cells(I, K + 7 - 1).NumberFormat = "@"
                        WS.Cells(I, K + 7 - 1) = Format(NoteItem(K), "@")
                    End Select
                Else
                    
                    If InStr(1, Note, "@") <> 0 Then
                        '---> in any sequence is @ is encountered make sure it is positioned
                        '     in Col P as it is the Price Column the rest will follow.
                        If Left(NoteItem(K), 1) = "@" And K + 7 + Z <> 16 Then
                            Z = 16 - 7 - K
                        End If
                    Else
                        If K + 7 + Z = 16 Then
                            Z = 16 - 7 - K + 1
                        End If
                    End If
                    WS.Cells(I, K + 7 + Z).NumberFormat = "@"
                    WS.Cells(I, K + 7 + Z) = Format(NoteItem(K), "@")
                End If
            Next K
        End If
    Next J
Next I


'---> Loop Again thru all the notes in the Account Order History section
'     and match the columns where there is data to find the threads in sheet output
'     Columns in Sheet   G H I J K L M N  O  P  Q
'     Columns in Output  G H E I - [K] L  M  P  Q
'     Column Num Output  7   5 9    11 12 13 16 17
'     Columns to check   Y   Y Y    Y  Y  Y  Y  Y

For I = FMRow + 1 To TORow
    
    If WS.Cells(I, "F") <> "" Then
        wsopt.UsedRange.AutoFilter 1, Criteria1:=""
        If WS.Cells(I, "G") <> "" Then wsopt.UsedRange.AutoFilter 7, WS.Cells(I, "G")
        If WS.Cells(I, "I") <> "" Then wsopt.UsedRange.AutoFilter 5, WS.Cells(I, "I")
        If WS.Cells(I, "J") <> "" Then wsopt.UsedRange.AutoFilter 9, WS.Cells(I, "J")
        If WS.Cells(I, "L") <> "" Then
            If Len(WS.Cells(I, "L")) = 3 Then
                On Error Resume Next
                STMonth = DateSerial(WS.Cells(I, "M"), Month(DateValue(WS.Cells(I, "L") & " 1," & Year(Now))), 1)
                ENDMonth = DateSerial(Year(STMonth), Month(STMonth), Day(Application.WorksheetFunction.EoMonth(STMonth, 0)))
                wsopt.UsedRange.AutoFilter 11, Criteria1:=">=" & STMonth, Operator:=xlAnd, Criteria2:="<=" & ENDMonth
            Else
                On Error Resume Next
                STMonth = DateValue(Left(WS.Cells(I, "L"), 3) & " " & Right(WS.Cells(I, "L"), Len(WS.Cells(I, "L")) - 3) & "," & WS.Cells(I, "M"))
                wsopt.UsedRange.AutoFilter 11, Criteria1:=">=" & STMonth, Operator:=xlAnd, Criteria2:="<=" & STMonth
            End If
        End If
        On Error GoTo 0
        If WS.Cells(I, "N") <> "" And InStr(1, WS.Cells(I, "N"), "/") = 0 Then wsopt.UsedRange.AutoFilter 12, WS.Cells(I, "N")
        If WS.Cells(I, "O") <> "" And InStr(1, WS.Cells(I, "N"), "/") = 0 Then wsopt.UsedRange.AutoFilter 13, WS.Cells(I, "O")
        'If WS.Cells(I, "P") <> "" Then wsopt.UsedRange.AutoFilter 16, Criteria1:="<=" & Val(Right(WS.Cells(I, "P"), Len(WS.Cells(I, "P")) - 1))
        If WS.Cells(I, "Q") <> "" Then wsopt.UsedRange.AutoFilter 17, WS.Cells(I, "Q")
        NoteFound = NoteFound + 1
        FoundIT = True
        
        For Each Row In wsopt.Range("11:" & MaxRow).EntireRow.SpecialCells(xlCellTypeVisible).Rows
            If wsopt.Cells(Row.Row, "A").EntireRow.Hidden = False And wsopt.Cells(Row.Row, "C") <> "" And Row.Row <> 11 Then
                wsopt.Cells(Row.Row, "A") = WS.Cells(I, "F")
                RowMatched = RowMatched + 1
                FoundIT = False
                Exit For
            End If
        Next Row
        
        If FoundIT Then
            'MsgBox (WS.Cells(I, "F") & Chr(10) & "Was not mached in sheet Output !")
            WS.Cells(I, "F").Interior.ColorIndex = 3
            UnMatchedNotes = UnMatchedNotes + 1
        End If
        
        '---> Clear All Filters
        wsopt.UsedRange.AutoFilter 1
        wsopt.UsedRange.AutoFilter 5
        wsopt.UsedRange.AutoFilter 7
        wsopt.UsedRange.AutoFilter 9
        wsopt.UsedRange.AutoFilter 11
        wsopt.UsedRange.AutoFilter 12
        wsopt.UsedRange.AutoFilter 13
        wsopt.UsedRange.AutoFilter 16
        wsopt.UsedRange.AutoFilter 17
    End If
Next I

MsgBox ("A total of " & RowMatched & " Spread items were matched with notes." & Chr(10) _
& "A total of " & NoteFound & " Notes FILLED were found in the Order History Section." & Chr(10) _
& "A total of " & UnMatchedNotes & " Notes were not Matched in Sheet Output.")

End Sub
Private Sub cleanOutput()
Dim r As Range, rng As Range
Dim lastRow As Long
Dim cntAddr As String

    'assumes output tab just generated and thus doesn't have total row already, etc., as it had been previously cleared...
    
    'Freeze panes on the first 11 rows so that the header row will always be visible when scrolling.

    ThisWorkbook.Activate 'just in case another workbook is on top

    wsopt.Activate 'just in case another worksheet is in focus
    wsopt.Range("12:12").Select
    ActiveWindow.FreezePanes = False
    ActiveWindow.FreezePanes = True
    
    'Shorten the name of the Order Type column to just Order.
    
    wsopt.Range("Q11").Value = "Order"
    
    'Rename the OT column to say Period and the data in it where M becomes Monthly spelled out, and O becomes Other spelled out.
    
    wsopt.Range("J11").Value = "Period"
    
    lastRow = wsopt.Range("A" & wsopt.Rows.Count).End(xlUp).Row
    Set r = wsopt.Range(wsopt.Range("J12"), wsopt.Cells(lastRow, "J"))
    
    'in case none found, turn on error trap
    On Error Resume Next
    r.Replace what:="M", replacement:="Monthly", lookAt:=xlWhole
    r.Replace what:="O", replacement:="Other", lookAt:=xlWhole
    On Error GoTo 0
    
    'Left justify the data in all columns except for P#, S#, L#, Qty, Strike, Days which should be centered.
    
'MOST DATA CENTERED - However, all the remaining data columns themselves with the exception of Qty should be centered. This will improve readability a great deal. Qty is different though because of the minus (-) sign. My thinking is that it should be right justified with a 2 space offset to give the illusion that it is centered also but still take into account the minus (-) sign in front of some of the numbers.
       
    Set r = wsopt.Range(wsopt.Range("B12"), wsopt.Cells(lastRow, "S"))
    With r
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    
    'now make Notes left justified
    Set r = wsopt.Range("A12:A" & lastRow)
    With r
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
    End With
    
    'and O, P, R & S should be right justified
    Set r = Union(wsopt.Range("O12:O" & lastRow), wsopt.Range("P12:P" & lastRow), wsopt.Range("R12:R" & lastRow), wsopt.Range("S12:S" & lastRow))
    With r
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
    End With
    
    'format Qty so numbers without negatives are one space over
    Set r = wsopt.Range("H12:H" & lastRow)
    r.NumberFormat = "[<0]-0;+0"
    
    Set r = wsopt.Range("N12:N" & lastRow)
    r.NumberFormat = "[<0]0;0"
    
    
    'Add a Total Row at the bottom that simply displays a count for the number notes that are filled in for that column, and leaves every other total empty.
    Call Add_TotalRow_2_ExistingTable
    cntAddr = wsopt.Range(wsopt.Cells(12, 1), wsopt.Cells(lastRow, 1)).Address
    wsopt.Range("A" & lastRow + 1).Formula = "=COUNTA(" & cntAddr & ")"

    
'COMPLETE HEADINGS - Adjust macro to replace column headings in the resulting Output tab for P#, S#, and L# and instead use headings Pos#, Spread# and Leg#.
    wsopt.Range("B11").Value = "Pos#"
    wsopt.Range("D11").Value = "Spread#"
    wsopt.Range("F11").Value = "Leg#"
'HEADER LEFT - A reconsideration of the formatting rules leads me to believe that the header row of the resulting Output tab as well as the data in the Notes column should still be left justified.
    With wsopt.Range("A11:S11")
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
    End With
   
    'Auto-fit all columns to width of data with the exception of the Notes column.
    wsopt.Range("B:S").EntireColumn.AutoFit
        
    'fix header row
    With Range("A11:S11").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
    Call highlightSpreads(lastRow)
    
    'Always return focus to cell A1.
    wsopt.Range("A1").Select
    ActiveWindow.ScrollRow = 1
    ActiveWindow.ScrollColumn = 1

End Sub
Sub highlightSpreads(lastRow As Long)
Dim r As Range
Dim rng As Range
Dim lastSpread As Long
Dim topSpread As Range
Dim botSpread As Range
Dim rSpread As Range
'Dark Red: R61 / G10 / B10 / #3D0A0A
'Dark Green: R10 / G61 / B10 / #0A3D0A

    Set rng = wsopt.Range("D12:D" & lastRow)
    
    lastSpread = rng.Cells(1, 1).Value
    Set topSpread = rng.Cells(1, 1)
    Set botSpread = rng.Cells(1, 1)
    
    For Each r In rng
        If r.Font.Color <> vbWhite Then
            If r.Value = lastSpread Then
                Set botSpread = r
            Else
                If True Then 'botSpread.Row > topSpread.Row Then
                    'highlight spread
                    Set rSpread = wsopt.Range(wsopt.Cells(topSpread.Row, "A"), wsopt.Cells(botSpread.Row, "S"))
                    If topSpread.Offset(, 3).Value = "BUY" Then
                        rSpread.Interior.Color = RGB(10, 61, 10) 'vbGreen
                        rSpread.Font.Color = RGB(255, 220, 0)
                    Else
                        rSpread.Interior.Color = RGB(61, 10, 10) 'vbRed
                        rSpread.Font.Color = RGB(255, 220, 10)
                    End If
                End If

                lastSpread = r.Value
                Set topSpread = r
                Set botSpread = r
            End If
        End If
    Next r
End Sub
Private Sub Add_TotalRow_2_ExistingTable()
'Source adapted from:http://vbadud.blogspot.com/2008/07/add-total-row-to-excel-table-using-vba.html
Dim oWS As Worksheet ' Worksheet Object
Dim oRange As Range ' Range Object - Contains Represents the List of Items that need to be made unique
Dim oLst As ListObject ' List Object
Dim oLC As ListColumn ' List Column Object


On Error GoTo Disp_Error

Set oWS = ActiveSheet
If oWS.ListObjects.Count = 0 Then Exit Sub

Set oLst = oWS.ListObjects(1)
oLst.ShowTotals = True

' Change/Set the formatting of the Totals Row
oLst.TotalsRowRange.Font.Bold = True
'oLst.TotalsRowRange.Font.Color = vbRed


If Not oLC Is Nothing Then Set oLC = Nothing
If Not oLst Is Nothing Then Set oLst = Nothing
If Not oWS Is Nothing Then Set oWS = Nothing

' --------------------
' Error Handling
' --------------------
Disp_Error:
If Err <> 0 Then
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, "VBA Tips & Tricks Examples"
Resume Next
End If


End Sub

Open in new window


Dave
0
 
rtod2Author Commented:
Excellent, thank you guys very much!  Point split was 200 to gowflow and 300 to dlmille with a grade of A.

On to calculations...
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.