Improve efficiency of macro

Per a suggestion by goflow, I want to see if we can improve the efficiency of the macro while still getting the same results.  I am concerned that we want to keep all the comments and not loose any of those unless they are irrelevant.  Here is the latest code.  Thank you for the assistance!!


Option Explicit
'--> This macro takes either pm or rm tabs and creates a properly formatted table in a new tab'
'called Output with the data from the Trade History section of the original tab. It also takes'
'the notes from the Order History section of the original tab and then indexes and sorts each'
'Spread into meaningful positions.'

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

Const AOH = "Account Order History"
Const ATH = "Account Trade History"
Const PAL = "Profits and Losses"
Const EQT = "Equities"
Const OPT = "Options"
Dim wsopt As Worksheet
    

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

Sub TradeReport()
    Dim wsPM As Worksheet
    Dim aCell As Range, bCell As Range, cCell As Range, delRange As Range
    Dim AOHRow As Long, PALRow As Long, ATHRow As Long
    Dim LastRow As Long, I As Long, J As Long
    Dim shName As String
    Dim SearchString As String, MatchString As String, init1String As String, init2String As String
    Dim intNum  As Long
    
    On Error GoTo Whoa
    
    Application.ScreenUpdating = 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
        
        '--> Find the "Profits and Losses" cell in Sheet PM'
        Set bCell = wsPM.Columns(1).Find(What:=PAL, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
        If shName = "rm" Then
            '--> Find the "Equities" cell in Sheet RM'
            Set bCell = wsPM.Columns(1).Find(What:=EQT, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        Else
            '--> Find the "Options" cell in Sheet PM'
            Set bCell = wsPM.Columns(1).Find(What:=OPT, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        End If
        
        '--> If "Profits and Losses" is found'
        If Not bCell Is Nothing Then
            '--> Get the starting row of "Profits and Losses"
            PALRow = bCell.Row
            
            '--> Output Trade History to new tab.'
            wsPM.Rows((ATHRow + 1) & ":" & (PALRow - 1)).Copy wsopt.Rows(1)
            
            If shName = "rm" Then
                wsopt.Select
                Columns("A:A").Select
                Selection.Insert Shift:=xlToRight
            End If
            
            With wsopt
                '--> Remove last three columns because they are duplicates.'
                .Columns("M:O").Delete Shift:=xlToLeft
                
                '--> Define the notes column.'
                .Range("A1").Value = "Notes"
                .Columns("A:A").Replace What:="DEFAULT", Replacement:="", LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
                
                '--> Get the last row of Output Sheet'
                LastRow = .Cells.Find(What:="*", after:=[A1], SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious).Row
                   
                '--> Unsure of what this section does?'
                Set cCell = wsPM.Columns(1).Find(What:=AOH, LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
                
                If Not cCell Is Nothing Then
                    AOHRow = cCell.Row + 1
                    
                '--> Copy the notes into the new notes column.'
                    For I = AOHRow To ATHRow
                        SearchString = wsPM.Range("D" & I).Value & "###" & _
                        wsPM.Range("F" & I).Value & "###" & _
                        wsPM.Range("G" & I).Value & "###" & _
                        wsPM.Range("H" & I).Value & "###" & _
                        wsPM.Range("I" & I).Value
                
                        init1String = wsPM.Range("F" & I).Value
                
                        For J = 2 To LastRow
                            init2String = wsopt.Range("F" & J).Value
                
                            If init1String = init2String Then
                                MatchString = .Range("D" & J).Value & "###" & _
                                              .Range("F" & J).Value & "###" & _
                                              .Range("G" & J).Value & "###" & _
                                              .Range("H" & J).Value & "###" & _
                                              .Range("I" & J).Value
                
                                If MatchString = SearchString Then
                                    .Range("A" & J).Value = wsPM.Range("A" & I).Value
                                End If
                            End If
                        Next J
                    Next I
                End If
                
                '--> Make the Output tab into a table that can be filtered by the column headers.'
                .ListObjects.Add(xlSrcRange, Range("$A$1:$L$" & LastRow), , xlYes).Name = "Table1"
                .ListObjects("Table1").ShowTableStyleRowStripes = False
                'ListObjects("Table1").TableStyle = "TableStyleLight1"'
                .Columns("B:L").EntireColumn.AutoFit
                
            End With
        End If
    End If
    Application.ScreenUpdating = False
    NewUpdates
    FixDate
    Indexing
    Sorting
    AddMOColumn
    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.'

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

Open in new window

rtod2Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

rtod2Author Commented:
One thing I am noticing also which may have nothing to do with efficiency but does affect new changes to the code is that columns are referenced by letters while the should probably be referenced by their headers. I am not sure whether that should change or stay the same. Please do what you see fit and I will have a look.

I think you are right about the efficiency but am concerned that we maintain the proper order and sequence.
0
NorieData ProcessorCommented:
Don't suppose there's a workbook attached anywhere?
0
rtod2Author Commented:
imnorie,
Thank you sir. Here is the latest copy of the workbook itself. Please try not to re-post the workbook but rather only the code here if possible.
0
The Ultimate Tool Kit for Technolgy Solution Provi

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 for valuable how-to assets including sample agreements, checklists, flowcharts, and more!

rtod2Author Commented:
The latest code has been attached to the workbook itself as well as pasted below. It is an update from what is in the first post. Thank you VERY much from your help with making this more efficient
Option Explicit
'--> This macro takes either pm or rm tabs and creates a properly formatted table in a new tab'
'called Output with the data from the Trade History section of the original tab. It also takes'
'the notes from the Order History section of the original tab and then indexes and sorts each'
'Spread into meaningful positions.'

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

Const AOH = "Account Order History"
Const ATH = "Account Trade History"
Const PAL = "Profits and Losses"
Const EQT = "Equities"
Const OPT = "Options"
Dim wsopt As Worksheet
    

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
    
    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
        
        '--> Find the "Profits and Losses" cell in Sheet PM'
        Set bCell = wsPM.Columns(1).Find(What:=PAL, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
        If shName = "rm" Then
            '--> Find the "Equities" cell in Sheet RM'
            Set bCell = wsPM.Columns(1).Find(What:=EQT, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        Else
            '--> Find the "Options" cell in Sheet PM'
            Set bCell = wsPM.Columns(1).Find(What:=OPT, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        End If
        
        '--> If "Profits and Losses" is found'
        If Not bCell Is Nothing Then
            '--> Get the starting row of "Profits and Losses"
            PALRow = bCell.Row
            
            '--> Output Trade History to new tab.'
            wsPM.Rows((ATHRow + 1) & ":" & (PALRow - 1)).Copy wsopt.Rows(1)
            
            If shName = "rm" Then
                wsopt.Select
                Columns("A:A").Select
                Selection.Insert Shift:=xlToRight
            End If
            
            With wsopt
                '--> Remove last three columns because they are duplicates.'
                .Columns("M:O").Delete Shift:=xlToLeft
                
                '--> Define the notes column.'
                .Range("A1").Value = "Notes"
                .Columns("A:A").Replace What:="DEFAULT", Replacement:="", LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
                
                '--> Get the last row of Output Sheet'
                LastRow = .Cells.Find(What:="*", after:=[A1], SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious).Row
                   
                '--> Unsure of what this section does?'
                Set cCell = wsPM.Columns(1).Find(What:=AOH, LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
                
                If Not cCell Is Nothing Then
                    AOHRow = cCell.Row + 1
                    
                '--> Copy the notes into the new notes column.'
                    For I = AOHRow To ATHRow
                        SearchString = wsPM.Range("D" & I).Value & "###" & _
                        wsPM.Range("F" & I).Value & "###" & _
                        wsPM.Range("G" & I).Value & "###" & _
                        wsPM.Range("H" & I).Value & "###" & _
                        wsPM.Range("I" & I).Value
                
                        init1String = wsPM.Range("F" & I).Value
                
                        For J = 2 To LastRow
                            init2String = wsopt.Range("F" & J).Value
                
                            If init1String = init2String Then
                                MatchString = .Range("D" & J).Value & "###" & _
                                              .Range("F" & J).Value & "###" & _
                                              .Range("G" & J).Value & "###" & _
                                              .Range("H" & J).Value & "###" & _
                                              .Range("I" & J).Value
                
                                If MatchString = SearchString Then
                                    .Range("A" & J).Value = wsPM.Range("A" & I).Value
                                End If
                            End If
                        Next J
                    Next I
                End If
                
                '--> Make the Output tab into a table that can be filtered by the column headers.'
                .ListObjects.Add(xlSrcRange, Range("$A$1:$L$" & LastRow), , xlYes).Name = "Table1"
                .ListObjects("Table1").ShowTableStyleRowStripes = False
                'ListObjects("Table1").TableStyle = "TableStyleLight1"'
                .Columns("B:L").EntireColumn.AutoFit
                
            End With
        End If
    End If
    Application.ScreenUpdating = False
    NewUpdates
    FixDate
    Indexing
    Sorting
    AddMOColumn
    AddDaysandPLColumn
    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.'

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

Open in new window

0
gowflowCommented:
question
the main improvement is at the Copy note routine, looking at this routine I wonder if the one that you have is copying the notes correctly !!! Are you sure and positive that the way it is setup it copy the notes correctly ??? As looking at pm sheet and first record dated 12/8/2011  2:59:00 PMthe note attached to his item is: buy 1 second before close and if you look at the result of the present macro at this item the note shows:
BUY +1 STRANGLE BAC 100 (Weeklys) DEC2 11 6/5 CALL/PUT MKT SUBMIT AT 12/2/11 14:59:50 / SELL -1 STRANGLE BAC 100 (Weeklys) DEC2 11 6/5 CALL/PUT MKT TRG BY #204030170 SUBMIT AT 12/5/11 07:00:00: Buy OTM straddle weekly with 7 days prior to weekend

Is this how it is supposed to be ?

I have the routine optimized already but was looking to make sure data is correctly reported when I found this discrepancy.
Pls advise.
gowflow
0
rtod2Author Commented:
hmm,
Not sure I understand 100%.  I know that the format of PM vs RM is slightly different.  Attached is yet another CSV to test against.  The macro is currently giving an error when running against it.  In terms of the originally written instructions for the notes, they are as follows:

"Copy the notes from all the identical trades in the Order History of the original tab and place those notes into that same column of the Trade History in the Output tab such that notes for all 'Filled' orders of the Order History are also reflected in the Trade History of the Output tab. To ensure the accuracy of the match, The Orders need to have met both the  Filled' condition AND the Side+Symbol+Exp+Strike+Type of the original Order History should match the Side+Symbol+Exp+Strike+Type of the Trade History in the Output tab. If both conditions are true, than you can be reasonably certain you have matched the note in the order history to the correct trade in the trade history. All 'Filled' orders in the original Order History sheet should have made it over to the notes in the table of the Output tab."

It is important to note that the Qty does not enter the equation because it is possible to have placed an order for 30 of something and only be 'filled' on 29.  We are utterly unconcerned with anything that isn't filled, and all filled items should be accounted for.
0
rtod2Author Commented:
0
gowflowCommented:
EXACTLY
Side+Symbol+Exp+Strike+Type on original side should match
Side+Symbol+Exp+Strike+Type on the output side !!!

Well whoever wrote this macro has indeed taken on the Original side but has taken the exact same reference column for the Output side whcih make the Output side look for
S#+L#+Side+Qty+Symbol

Total diffrent salada !!!
I will fix this.

What d oyou mean:
The macro is currently giving an error when running against it. ? Is it my macro that is giving an error due to my code ? pls clarify what is the error and what line is turning yellow ?
gowflow
0
rtod2Author Commented:
goflow,

What a catch sir!!  Thank you.

The error is a run-time error 13 as pictured here http://screencast.com/t/J43Df2ikK3Gw.

Also, I have an even better clarification of what notes get transferred to Output.

To ensure the accuracy of the match for which Notes get transferred to Output, ALL of the following should be true.

1. The Orders in Order History should have been FILLED, otherwise the notes for them are irrelevant.
2. The Side+Symbol+Exp+Strike+Type of the original Order History should match the Side+Symbol+Exp+Strike+Type of the Trade History.
3. One could also say that the Exec Time in the Trade History must be the same or come after the Exec Time in the Order History.

** It is important to note that the Qty does not enter the equation because it is possible to have placed an order for 30 of something and only be filled on 29.  We are utterly unconcerned with anything that isn't filled, and all filled items should be accounted for.
0
rtod2Author Commented:
the error above was when running it against the rmexport.
0
gowflowCommented:
rmexport is weired you get the date in the column notes and the titles are diffrent !!! and you don't get exec time column don't know the format of this sheet looks diffeent now this is a total diffrent issue for sure the macro will stall somewhere if the format is not identical !!! can't ride a car expecting it will be a plane Right !!!? ???
gowflow
0
gowflowCommented:
ooops got it !!!
Your original macro is designed to work with sheets called rm or pm !!! change the name of rmexport to rm and it will work with no error !
gowflow
0
gowflowCommented:
here are my comments regarding the Notes:
In sheet pm you have the notes that are part of the rest of fields then this is no sweat to make it correctly polled by the basis you just discribed earler.

In sheet rm the notes are part of Order History that have 3 columns
Account Order History                  
Notes      Order ID      Description      Status
      291740652      SELL -135 1/2 BACKRATIO SPY 100 AUG 11 135/132 PUT @1.54 LMT PHLX [TO CLOSE/TO CLOSE]      (-118) CANCELED

Under notes there is nothing under description there is data and orderid but problem is how you match an item in the trade items don't have any orderid !!! this is why all notes are blank for rm sheet is this ok or you want to transfer the description field to notes ? if yes what is the criteria ???

gowflow
0
rtod2Author Commented:
I see the issue.  In the 2 csv exports provided, the notes need to be pulled if available but on the filled items only. That is troubling though and I see your point.  I have tried to illustrate my understanding in the image below. It is clear that the only description is of the 'spread' and not each individual leg, and it is crammed together to the left of the actual note that I am trying to pull.


description-of-spread-in-note.png
0
gowflowCommented:
Sorry but seems we are mixing 2 issues in this question we started with optimizing the code and now onto other issue which is the note.

I can look at the note separately but had to make the comment coz you mentioned the error that was due to naming the sheet properly to either pm or rm.

Here is the code optimized not to my entire wish as you have an indexing sub that I will need more time to digest order decript and understand the functionning but the version you have here brings processing of the sheet rm from 30 sec down to only 14 sec whcih is an improvement of 114%. I beleive it can be mor eoptimized after revewing Indexing whcih I beleive in light of the note developpment is no more a priority right now.

Pls try out this code and see if it is agreable to you and if any other error. If you want me to look at the Notes issue I guess we can treat that separately as the pic you posted is too small to be able to read anything on it.

PS in the Sub TradeReport I kept your original routine that was taking too long to process and I add the new routine on top of it and once it execute it by-passes the old routine to continue the rest of the code. I prefer to leave it this way for now as it is all about the notes that are only showing so far in sheet pm that are only couple of lines
.
gowflow
Option Explicit
'--> This macro takes either pm or rm tabs and creates a properly formatted table in a new tab'
'called Output with the data from the Trade History section of the original tab. It also takes'
'the notes from the Order History section of the original tab and then indexes and sorts each'
'Spread into meaningful positions.'

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

Const AOH = "Account Order History"
Const ATH = "Account Trade History"
Const PAL = "Profits and Losses"
Const EQT = "Equities"
Const OPT = "Options"
Dim wsopt As Worksheet
    

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
        
        '--> Find the "Profits and Losses" cell in Sheet PM'
        Set bCell = wsPM.Columns(1).Find(What:=PAL, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
        If shName = "rm" Then
            '--> Find the "Equities" cell in Sheet RM'
            Set bCell = wsPM.Columns(1).Find(What:=EQT, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        Else
            '--> Find the "Options" cell in Sheet PM'
            Set bCell = wsPM.Columns(1).Find(What:=OPT, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        End If
        
        '--> If "Profits and Losses" is found'
        If Not bCell Is Nothing Then
            '--> Get the starting row of "Profits and Losses"
            PALRow = bCell.Row
            
            '--> Output Trade History to new tab.'
            wsPM.Rows((ATHRow + 1) & ":" & (PALRow - 1)).Copy wsopt.Rows(1)
            
            If shName = "rm" Then
                wsopt.Select
                Columns("A:A").Select
                Selection.Insert Shift:=xlToRight
            End If
            
            With wsopt
                '--> Remove last three columns because they are duplicates.'
                .Columns("M:O").Delete Shift:=xlToLeft
                
                '--> Define the notes column.'
                .Range("A1").Value = "Notes"
                .Columns("A:A").Replace What:="DEFAULT", Replacement:="", LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
                
                '--> Get the last row of Output Sheet'
                LastRow = .Cells.Find(What:="*", after:=[A1], SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious).Row
                   
                '--> Unsure of what this section does?'
                Set cCell = wsPM.Columns(1).Find(What:=AOH, LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
                
                If Not cCell Is Nothing Then
                    AOHRow = cCell.Row + 1
                    
                '--> Copy the notes into the new notes column.
                    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
    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.'

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

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
rtod2Author Commented:
Outstanding!

I think I have landed on an idea to abandon using the columns to determine a match and simply use information at the beginning of the notes themselves to determine a match not for any individual leg but for any position that contains everything in the note besides the qty.  I will post a question toward that end and see what we can put our heads together on over the next few days. There may be some back-and-forth on it.

Thanks for all your help.
0
gowflowCommented:
tks for your usual nice coments and grade much appreciated. Will indeed follow-up on notes.
gowflow
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.