Improve visual formatting (take two).
A BIG THANKS goes out to gowflow and dlmille for all the hard work so far on this.
Modify existing code noted below for this workbook to provide the following formatting tweaks. Please try not to re-post the original workbook but do post the complete code if modified. I greatly appreciate the assistance.
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#.
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.
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.
Assistance is greatly appreciated and the newly commented code is pasted below.
Modify existing code noted below for this workbook to provide the following formatting tweaks. Please try not to re-post the original workbook but do post the complete code if modified. I greatly appreciate the assistance.
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#.
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.
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.
Assistance is greatly appreciated and the newly commented code is pasted below.
'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
Sub cleanOutput()
Dim r As Range, rng As Range
Dim lastRow As Long
'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.
'first make all left justified
Set r = wsopt.Range(wsopt.Range("A12"), wsopt.Cells(lastRow, "S"))
With r
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
End With
'now make particular columns centered
Set r = Union(wsopt.Range("H12:H" & lastRow), wsopt.Range("L12:L" & lastRow), wsopt.Range("N12:N" & lastRow), wsopt.Range("P12:P" & lastRow), wsopt.Range("S12:S" & lastRow))
With r
.HorizontalAlignment = xlCenter
End With
'Header row should always remain left justified.
'
'Nothing to do?
'
'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.
For Each r In wsopt.Range("A" & lastRow + 2, wsopt.Range("S" & lastRow + 2))
If r.Column = 1 Then
r.Value = "TOTAL"
ElseIf IsNumeric(wsopt.Cells(12, r.Column).Value) Then 'test the last row for numeric versus text values - if numeric, then provide count
Dim cntAddr As String
cntAddr = wsopt.Range(wsopt.Cells(12, r.Column), wsopt.Cells(lastRow, r.Column)).Address
r.Value = Evaluate("COUNT(" & cntAddr & ")")
End If
Next r
'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
I figured it out - the custom format to push non-negative numbers over one is:
[<0]-0; 0
its an if-statement as part of the customization - if negative then do -0. if not then space 0. :) pretty neat
See attached complete code with all requests completed.
Dave
[<0]-0; 0
its an if-statement as part of the customization - if negative then do -0. if not then space 0. :) pretty neat
See attached complete code with all requests completed.
Dave
'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
'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 Qty & Notes left justified
Set r = Union(wsopt.Range("A12:A" & lastRow), wsopt.Range("H12:H" & lastRow))
With r
.HorizontalAlignment = xlLeft
.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"
'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.
For Each r In wsopt.Range("A" & lastRow + 2, wsopt.Range("S" & lastRow + 2))
If r.Column = 1 Then
r.Value = "TOTAL"
ElseIf IsNumeric(wsopt.Cells(12, r.Column).Value) Then 'test the last row for numeric versus text values - if numeric, then provide count
Dim cntAddr As String
cntAddr = wsopt.Range(wsopt.Cells(12, r.Column), wsopt.Cells(lastRow, r.Column)).Address
r.Value = Evaluate("COUNT(" & cntAddr & ")")
End If
Next r
'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("P11").Value = "Pos#"
wsopt.Range("S11").Value = "Spread#"
wsopt.Range("L11").Value = "Lag#"
'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 SubASKER
Dave, Thank you, sir!
In answer to your question, not really because it will disturb the readability for those later on. The reason for this is that traders are used to seeing that data in that format. A minus - means sell where a plus + means buy. It would distort the perceived meaning of that data among traders to use a parenthesis there.
In answer to your question, not really because it will disturb the readability for those later on. The reason for this is that traders are used to seeing that data in that format. A minus - means sell where a plus + means buy. It would distort the perceived meaning of that data among traders to use a parenthesis there.
Ok then. My last post didn't require that, so negatives have the - sign. To the best of my knowledge, you have now what you asked for unless I somehow missed something. Great clear expectations, by the way.
Cheers,
Dave
Cheers,
Dave
ASKER
I think I just answered myself. What about using a + and a - and formatting as a number? Then it could be centered along with the rest without an issue, correct?
Actually with the formatting I did, leaving Qty centered looks great - no + necessary
Here's the code:
Dave
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 cleanOutput()
Dim r As Range, rng As Range
Dim lastRow As Long
'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
'format Qty so numbers without negatives are one space over
Set r = wsopt.Range("H12:H" & 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.
For Each r In wsopt.Range("A" & lastRow + 2, wsopt.Range("S" & lastRow + 2))
If r.Column = 1 Then
r.Value = "TOTAL"
ElseIf IsNumeric(wsopt.Cells(12, r.Column).Value) Then 'test the last row for numeric versus text values - if numeric, then provide count
Dim cntAddr As String
cntAddr = wsopt.Range(wsopt.Cells(12, r.Column), wsopt.Cells(lastRow, r.Column)).Address
r.Value = Evaluate("COUNT(" & cntAddr & ")")
End If
Next r
'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("P11").Value = "Pos#"
wsopt.Range("S11").Value = "Spread#"
wsopt.Range("L11").Value = "Lag#"
'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 SubDave
ASKER
Your code is behaving differently with rm data than it is with pm data. The column headers at least with pm data aren't processing correctly. Still some work needed on that one.
ASKER
Dave, Thank you. I think I may be wrong on the statement in the forementioned post ID #37391833 but there is still a problem with the headings non-the-less. Please see my video explanation here http://screencast.com/t/FNTMxoj1.
ASKER
I'm also noticing that the Total row you created on the previous related question is incorrect. The Total Row is a feature of the table and should only include a value for the number of notes that exist. This will be used later for troubleshooting the notes issue with gowflow. What we have currently is not a Total Row at all as defined in the first post of the related question and in fact isn't really part of the table at all. One feature of a Total Row when part of a table, is that it adjusts it's values automatically when the sheet table is filtered.
The video helped. you may note your comments at the top:
>>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#.
I thought you meant column P, S and L.
Corrected as requested exactly in the above to Pos#, Spread# and Leg#
>>show the +
Done
>> add absolute value change to column N days to expire
Done
>>Fix total row - actually your original post was: "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." so there was some left to interpretation ;)
Give me a few moments to look at that.
Here's the current code:
Dave
>>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#.
I thought you meant column P, S and L.
Corrected as requested exactly in the above to Pos#, Spread# and Leg#
>>show the +
Done
>> add absolute value change to column N days to expire
Done
>>Fix total row - actually your original post was: "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." so there was some left to interpretation ;)
Give me a few moments to look at that.
Here's the current 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 cleanOutput()
Dim r As Range, rng As Range
Dim lastRow As Long
'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
'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.
For Each r In wsopt.Range("A" & lastRow + 2, wsopt.Range("S" & lastRow + 2))
If r.Column = 1 Then
r.Value = "TOTAL"
ElseIf IsNumeric(wsopt.Cells(12, r.Column).Value) Then 'test the last row for numeric versus text values - if numeric, then provide count
Dim cntAddr As String
cntAddr = wsopt.Range(wsopt.Cells(12, r.Column), wsopt.Cells(lastRow, r.Column)).Address
r.Value = Evaluate("COUNT(" & cntAddr & ")")
End If
Next r
'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("P11").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 SubDave
ASKER
Dave,
Thank you again sir. Here is another video http://screencast.com/t/JmIkIjAtLm5 which is based on the newest code in the post ID #37391870 just above this.
Thank you again sir. Here is another video http://screencast.com/t/JmIkIjAtLm5 which is based on the newest code in the post ID #37391870 just above this.
Thanks for the clarification. Additional formatting noted and handled.
here's the code:
Dave
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 cleanOutput()
Dim r As Range, rng As Range
Dim lastRow As Long
'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
For Each r In wsopt.Range("A" & lastRow + 1, wsopt.Range("S" & lastRow + 1))
If r.Column = 1 Then
'do nothing
ElseIf IsNumeric(wsopt.Cells(12, r.Column).Value) Then 'test the last row for numeric versus text values - if numeric, then provide count
Dim cntAddr As String
cntAddr = wsopt.Range(wsopt.Cells(12, r.Column), wsopt.Cells(lastRow, r.Column)).Address
r.Value = Evaluate("COUNT(" & cntAddr & ")")
End If
Next r
'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
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 SubDave
PS - the header row is absolutely centered.
Dave
Dave
ASKER
Dave, thank you for the note about the header row. It is very good to know that I can just say centered and no longer have to spell that out when describing that kind of thing. The total row is still a bit off from what I attempted to describe in the other thread. Please forgive my less than clear description. Here is the video of what I am trying to do there http://screencast.com/t/YYtJtgiKoz.
also apologize for nit picking your descriptions. It takes 2 to communicate at least :)
PS - your screencast is inoperable. Can you try it and see if it works for you?
Dave
PS - your screencast is inoperable. Can you try it and see if it works for you?
Dave
ASKER
Yep, works great! The only problem is the total row. I just checked the screencast though and it plays. Here it is again illustrating the issue with the total row http://screencast.com/t/YYtJtgiKoz.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Was aiming at right justification for the total row but I can certainly live with it as is. Working on colorization next. Stay tuned and thank you a great deal for your help sir!
ASKER
Thank you again sir. Here is the new question >> https://www.experts-exchange.com/questions/27524637/Colorize-to-match-trading-platform.html
Open in new window
Let me know how it goes.
The only thing outstanding is to indent non negative Qty with one space - trying to figure that out without changing the data (using formats only). Would parenthesis around the negative numbers work? That way they could be formatted as numbers and then centered again?
let me know - try it manually and see what I mean.
Dave