Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Private racecardSheetName As String
- Private dataSheetName As String
- Private horseData As Object
- Dim originalData As Collection
- Private Sub ComboBox1_Change()
- Dim selectedValue As String
- Dim item As Variant
- selectedValue = ComboBox1.value
- ' Preserve the "All" option in the ComboBox
- If selectedValue = "All" Then
- ' Clear existing items from ListView2
- ListView2.ListItems.Clear
- PopulateChildListView horseData
- ' Add all items from originalData to ListView2
- 'For Each item In originalData
- 'ListView2.ListItems.Add , , item.Text ' Add the item to ListView2
- ' Add more subitems as needed
- 'Next item
- Else
- ' Clear existing items from ListView2
- ListView2.ListItems.Clear
- ' Filter the data based on the selected value
- For Each item In originalData
- If item.ListSubItems(4).Text = selectedValue Then
- Dim newItem As MSComctlLib.listItem
- Set newItem = ListView2.ListItems.Add(, , item.Text) ' Add the item to ListView2
- ' Add more subitems as needed
- newItem.ListSubItems.Add , , item.ListSubItems(1).Text ' Add subitem for column 2
- newItem.ListSubItems.Add , , item.ListSubItems(2).Text ' Add subitem for column 3
- newItem.ListSubItems.Add , , item.ListSubItems(3).Text ' Add subitem for column 4
- newItem.ListSubItems.Add , , item.ListSubItems(4).Text ' Add subitem for column 5
- newItem.ListSubItems.Add , , item.ListSubItems(5).Text ' Add subitem for column 6
- newItem.ListSubItems.Add , , item.ListSubItems(6).Text ' Add subitem for column 7
- newItem.ListSubItems.Add , , item.ListSubItems(7).Text ' Add subitem for column 8
- newItem.ListSubItems.Add , , item.ListSubItems(8).Text ' Add subitem for column 9
- newItem.ListSubItems.Add , , item.ListSubItems(9).Text ' Add subitem for column 10
- newItem.ListSubItems.Add , , item.ListSubItems(10).Text ' Add subitem for column 11
- newItem.ListSubItems.Add , , item.ListSubItems(11).Text ' Add subitem for column 12
- newItem.ListSubItems.Add , , item.ListSubItems(12).Text ' Add subitem for column 13
- newItem.ListSubItems.Add , , item.ListSubItems(13).Text ' Add subitem for column 14
- newItem.ListSubItems.Add , , item.ListSubItems(14).Text ' Add subitem for column 15
- newItem.ListSubItems.Add , , item.ListSubItems(15).Text ' Add subitem for column 16
- newItem.ListSubItems.Add , , item.ListSubItems(16).Text ' Add subitem for column 17
- newItem.ListSubItems.Add , , item.ListSubItems(17).Text ' Add subitem for column 18
- newItem.ListSubItems.Add , , item.ListSubItems(18).Text ' Add subitem for column 19
- newItem.ListSubItems.Add , , item.ListSubItems(19).Text ' Add subitem for column 20
- ' Add more subitems for additional columns
- ' ...
- End If
- Next item
- End If
- End Sub
- Private Sub PopulateComboBox()
- ComboBox1.Clear
- ComboBox1.AddItem "All" ' Add "All" value at the top
- Dim item As listItem
- Dim columnValue As String
- Dim itemExists As Boolean
- ' Assuming the column you want to extract values from is column 5 (index 4)
- For Each item In ListView2.ListItems
- columnValue = item.ListSubItems(4).Text
- ' Check if the value already exists in ComboBox
- itemExists = False
- For i = 0 To ComboBox1.ListCount - 1
- If ComboBox1.List(i) = columnValue Then
- itemExists = True
- Exit For
- End If
- Next i
- ' Add the value to ComboBox if it doesn't exist
- If Not itemExists Then
- ComboBox1.AddItem columnValue
- End If
- Next item
- End Sub
- Private Sub ListView1_BeforeLabelEdit(Cancel As Integer)
- ' Check if the edit is being performed on the first column (index 1) of ListView1
- If ListView1.ColumnHeaders(1).Index = 1 Then
- ' Cancel the label edit event
- Cancel = True
- End If
- End Sub
- Private Sub ListView2_BeforeLabelEdit(Cancel As Integer)
- ' Check if the edit is being performed on the first column (index 1) of ListView2
- If ListView2.ColumnHeaders(1).Index = 1 Then
- ' Cancel the label edit event
- Cancel = True
- End If
- End Sub
- Private Sub ListView1_ItemClick(ByVal item As MSComctlLib.listItem)
- PopulateComboBox
- ' Get the horse name from the clicked item
- Dim horseName As String
- horseName = item.Text ' Assuming horse name is stored in the first column
- ' Populate child ListView with data from Sheet2
- PopulateChildListView horseName
- End Sub
- Private Sub TreeView1_BeforeLabelEdit(Cancel As Integer)
- On Error Resume Next
- ' Get the currently edited node
- Dim editedNode As Node
- Set editedNode = TreeView1.SelectedItem
- ' Check if the edited node is a parent or child node
- If Err.Number <> 0 Then
- ' Error occurred, cancel the label edit
- Cancel = True
- ElseIf editedNode.Child <> "" Or editedNode.Parent <> "" Then
- ' Cancel the label edit
- Cancel = True
- End If
- On Error GoTo 0
- End Sub
- Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
- ' Clear existing items from parent ListView
- ListView2.ListItems.Clear
- ' Declare variables
- Dim raceCourse As String
- Dim raceTime As String
- Dim targetSheet As Worksheet
- Dim targetRow As Long
- Dim offTime As Date
- Dim course As String
- Dim raceName As String
- Dim raceDate As Date
- Dim prizeMoney As String
- Dim formattedPrizeMoney As String
- Dim regex As Object
- Dim raceDist As String
- Dim raceClass As String
- Dim raceType As String
- Dim going As String
- Dim fieldSize As String
- ' Check if clicked node is a child node
- If Not Node.Parent Is Nothing Then
- ' Get race course and race time from clicked nodes
- raceCourse = Node.Parent.Text
- raceTime = Node.Text
- ' Set target sheet
- Set targetSheet = Worksheets(racecardSheetName)
- ' Find match in column B
- On Error Resume Next
- targetRow = targetSheet.Evaluate("match(timevalue(""" & raceTime & """),b:b,0)")
- On Error GoTo 0
- If targetRow <> 0 Then
- ' Get race data from target row
- offTime = targetSheet.Cells(targetRow, 2).value
- course = targetSheet.Cells(targetRow, 3).value
- raceName = targetSheet.Cells(targetRow, 4).value
- raceDate = dateValue(targetSheet.Cells(targetRow, 1).value)
- prizeMoney = targetSheet.Cells(targetRow, 10).value
- raceDist = targetSheet.Cells(targetRow, 5).value
- raceClass = targetSheet.Cells(targetRow, 6).value
- raceType = targetSheet.Cells(targetRow, 7).value
- going = targetSheet.Cells(targetRow, 9).value
- fieldSize = targetSheet.Cells(targetRow, 8).value
- ' Create a regular expression object
- Set regex = CreateObject("VBScript.RegExp")
- With regex
- .Pattern = "\D" ' Match any non-digit character
- .Global = True ' Match all occurrences
- End With
- ' Remove non-numeric characters from prizeMoney
- prizeMoney = regex.Replace(prizeMoney, "")
- formattedPrizeMoney = "£" & Format(Val(prizeMoney), "#,##0")
- ' Display race data in labels
- TimeLbl.Caption = Format(offTime, "h:mm")
- CourseLbl.Caption = course
- RaceNameLbl.Caption = raceName
- DateLbl.Caption = Format(raceDate, "dd mmm yy")
- prizeLbl.Caption = formattedPrizeMoney
- distLbl.Caption = raceDist & "f"
- classLbl.Caption = raceClass
- raceTypeLbl = raceType
- goingLbl = going
- runnersLbl = fieldSize
- ' Populate parent ListView with data from Sheet1
- PopulateParentListView raceCourse, raceTime
- Else
- ' Display error message if no match was found
- MsgBox "No race found for " & raceTime & " at " & raceCourse
- End If
- End If
- End Sub
- Private Sub PopulateParentListView(ByVal raceCourseName As String, ByVal raceTime As String)
- ' Clear existing items from parent ListView
- ListView1.ListItems.Clear
- ' Set the target sheet
- Dim targetSheet As Worksheet
- Set targetSheet = Worksheets(racecardSheetName)
- ' Create dictionary to store horse names and row numbers
- 'Dim horseData As Object
- Set horseData = CreateObject("Scripting.Dictionary")
- ' Populate horse data dictionary based on raceCourseName and raceTime
- Dim lastRow As Long
- lastRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row
- Dim i As Long
- For i = 2 To lastRow
- Dim key As String
- key = raceCourseName & "_" & raceTime
- If Trim(targetSheet.Cells(i, 3).value) = Trim(raceCourseName) And Format(targetSheet.Cells(i, 2).value, "h:mm") = Format(timeValue(raceTime), "h:mm") Then
- Dim horseName As String
- horseName = targetSheet.Cells(i, 12).value
- ' Add horse name and row number to horse data dictionary
- horseData(horseName) = i
- End If
- Next i
- ' Populate parent ListView using horse data dictionary
- Dim horseNameKey As Variant
- For Each horseNameKey In horseData.Keys
- Dim rowIndex As Long
- rowIndex = horseData(horseNameKey)
- Dim listItem As MSComctlLib.listItem
- Set listItem = ListView1.ListItems.Add(, , horseNameKey) ' Column 1
- ' Add additional subitems
- listItem.SubItems(1) = targetSheet.Cells(rowIndex, 28).value ' Column 2
- listItem.SubItems(2) = targetSheet.Cells(rowIndex, 11).value ' Column 3
- listItem.SubItems(3) = targetSheet.Cells(rowIndex, 22).value ' Column 4
- listItem.SubItems(4) = targetSheet.Cells(rowIndex, 23).value ' Column 5
- listItem.SubItems(5) = targetSheet.Cells(rowIndex, 24).value ' Column 6
- listItem.SubItems(6) = targetSheet.Cells(rowIndex, 25).value ' Column 7
- listItem.SubItems(7) = targetSheet.Cells(rowIndex, 26).value ' Column 8
- listItem.SubItems(8) = targetSheet.Cells(rowIndex, 21).value ' Column 9
- listItem.SubItems(9) = targetSheet.Cells(rowIndex, 27).value ' Column 10
- listItem.SubItems(10) = targetSheet.Cells(rowIndex, 17).value ' Column 11
- listItem.SubItems(11) = targetSheet.Cells(rowIndex, 19).value ' Column 12
- ' Add more subitems as needed
- ' Additional settings optional data
- listItem.SubItems(12) = targetSheet.Cells(rowIndex, 13).value ' Column 13
- listItem.SubItems(13) = targetSheet.Cells(rowIndex, 15).value ' Column 14
- listItem.SubItems(14) = targetSheet.Cells(rowIndex, 16).value ' Column 15
- listItem.SubItems(15) = targetSheet.Cells(rowIndex, 18).value ' Column 16
- listItem.SubItems(16) = targetSheet.Cells(rowIndex, 20).value ' Column 17
- Next horseNameKey
- PopulateChildListView horseData '************************************************************************************************
- End Sub
- Sub PopulateChildListView(Optional ByVal horseName As Variant, Optional ByVal horseData As Object)
- ' Clear existing items from child ListView
- ListView2.ListItems.Clear
- ' Clear the originalData collection
- Set originalData = New Collection
- ' Set the target sheet (Sheet2)
- Dim targetSheet As Worksheet
- Set targetSheet = Worksheets(dataSheetName) ' Replace "Sheet2" with the actual name of the sheet
- ' Find the last row in Sheet2
- Dim lastRow As Long
- lastRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row
- ' Flag variable to indicate if any matching data is found
- Dim matchFound As Boolean
- matchFound = False
- If TypeName(horseName) = "String" Then
- ' Loop through the rows in Sheet2 and populate the ChildListView with matching data
- Dim i As Long
- For i = 2 To lastRow ' Assuming the data starts from row 2
- Dim horseNameSheet2 As String
- horseNameSheet2 = targetSheet.Cells(i, 22).value ' Assuming the horse name is in the first column of Sheet2
- ' Remove the region letters from the horse name in Sheet2
- Dim regionPos As Integer
- regionPos = InStr(horseNameSheet2, "(")
- If regionPos > 0 Then
- horseNameSheet2 = Trim(left(horseNameSheet2, regionPos - 1))
- End If
- ' Compare the horse names
- If StrComp(horseNameSheet2, horseName, vbTextCompare) = 0 Then
- Dim listItem As MSComctlLib.listItem
- Set listItem = ListView2.ListItems.Add(, , targetSheet.Cells(i, 1).value) ' Assuming the data you want to display is in the second column of Sheet2
- ' Call the subroutine to add subitems
- AddListViewSubItems listItem, targetSheet, i
- ' Add the item to the originalData collection
- originalData.Add listItem
- matchFound = True ' Set the flag to indicate a match was found
- End If
- Next i
- ElseIf TypeName(horseName) = "Dictionary" Then
- ' Loop through the horse names in the dictionary and retrieve matching rows from Sheet2
- Dim horseNameKey As Variant
- For Each horseNameKey In horseName.Keys
- Dim horseNameValue As String
- horseNameValue = CStr(horseNameKey)
- ' Loop through the rows in Sheet2 and populate the ChildListView with matching data
- Dim x As Long
- For x = 2 To lastRow ' Assuming the data starts from row 2
- Dim horseNameSheet22 As String
- horseNameSheet22 = targetSheet.Cells(x, 22).value ' Assuming the horse name is in the 22nd column of Sheet2
- ' Remove the region letters from the horse name in Sheet2
- Dim regionPos2 As Integer
- regionPos2 = InStr(horseNameSheet22, "(")
- If regionPos2 > 0 Then
- horseNameSheet22 = Trim(left(horseNameSheet22, regionPos2 - 1))
- End If
- ' Compare the horse names
- If StrComp(horseNameSheet22, horseNameValue, vbTextCompare) = 0 Then
- Dim listItem2 As MSComctlLib.listItem
- Set listItem2 = ListView2.ListItems.Add(, , targetSheet.Cells(x, 1).value) ' Assuming the data you want to display is in the first column of Sheet2
- ' Call the subroutine to add subitems
- AddListViewSubItems listItem2, targetSheet, x
- ' Add the item to the originalData collection
- originalData.Add listItem2
- matchFound = True ' Set the flag to indicate a match was found
- End If
- Next x
- Next horseNameKey
- End If
- ' Check if any matching data was found for the horse name(s)
- If Not matchFound Then
- MsgBox "No matching data found for horse name: " & horseName
- End If
- PopulateComboBox
- End Sub
- Private Sub AddListViewSubItems(ByVal listItem As MSComctlLib.listItem, ByVal targetSheet As Worksheet, ByVal i As Long)
- ' Add subitems to the ListView2
- listItem.SubItems(1) = targetSheet.Cells(i, 22).value ' Column 1
- listItem.SubItems(2) = targetSheet.Cells(i, 3).value ' Column 2
- listItem.SubItems(3) = targetSheet.Cells(i, 5).value ' Column 3
- listItem.SubItems(4) = targetSheet.Cells(i, 13).value ' Column 4
- listItem.SubItems(5) = targetSheet.Cells(i, 15).value ' Column 5
- Dim unformattedTime As String
- unformattedTime = targetSheet.Cells(i, 27).Text ' Assuming the time value is stored as text in the cell
- ' Assign the unformatted time to the SubItems property
- listItem.SubItems(6) = unformattedTime ' Column 7
- listItem.SubItems(7) = targetSheet.Cells(i, 18).value ' Column 8
- listItem.SubItems(8) = targetSheet.Cells(i, 16).value ' Column 9
- listItem.SubItems(9) = targetSheet.Cells(i, 21).value ' Column 10
- listItem.SubItems(10) = targetSheet.Cells(i, 7).value ' Column 12
- listItem.SubItems(11) = targetSheet.Cells(i, 25).value ' Column 13
- listItem.SubItems(12) = targetSheet.Cells(i, 33).value ' Column 14
- listItem.SubItems(13) = targetSheet.Cells(i, 34).value ' Column 15
- listItem.SubItems(14) = targetSheet.Cells(i, 26).value ' Column 16
- listItem.SubItems(15) = targetSheet.Cells(i, 19).value ' Column 17
- listItem.SubItems(16) = targetSheet.Cells(i, 17).value ' Column 18
- listItem.SubItems(17) = targetSheet.Cells(i, 30).value ' Column 19
- listItem.SubItems(18) = targetSheet.Cells(i, 32).value ' Column 20
- listItem.SubItems(19) = targetSheet.Cells(i, 39).value ' Column 3
- ' Add more subitems as needed
- End Sub
- Private Sub CreateListView1ColumnHeaders()
- ' Add column headers
- ListView1.ColumnHeaders.Clear
- ListView1.ColumnHeaders.Add , , "Horse Name" ' Column 1
- ListView1.ColumnHeaders.Add , , "Form" ' Column 2
- ListView1.ColumnHeaders.Add , , "Age" ' Column 3
- ListView1.ColumnHeaders.Add , , "HG" ' Column 4
- ListView1.ColumnHeaders.Add , , "WGT" ' Column 5
- ListView1.ColumnHeaders.Add , , "OR" ' Column 6
- ListView1.ColumnHeaders.Add , , "RPR" ' Column 7
- ListView1.ColumnHeaders.Add , , "TS" ' Column 8
- ListView1.ColumnHeaders.Add , , "Draw" ' Column 9
- ListView1.ColumnHeaders.Add , , "Jockey" ' Column 10
- ListView1.ColumnHeaders.Add , , "Trainer" ' Column 11
- ListView1.ColumnHeaders.Add , , "Comments" ' Column 12
- ' Add more column headers as needed
- 'Optional settings columns
- ListView1.ColumnHeaders.Add , , "Sex" ' Column 13
- ListView1.ColumnHeaders.Add , , "Dam" ' Column 14
- ListView1.ColumnHeaders.Add , , "Sire" ' Column 15
- ListView1.ColumnHeaders.Add , , "Owner" ' Column 16
- ListView1.ColumnHeaders.Add , , "Spotlight" ' Column 17
- Me.ListView1.Gridlines = True
- End Sub
- Private Sub CreateListView2ColumnHeaders()
- ' Add column headers*******************************************************************************
- ListView2.ColumnHeaders.Clear
- ListView2.ColumnHeaders.Add , , "Date" ' Column 1
- ListView2.ColumnHeaders.Add , , "Name" ' Column 2
- ListView2.ColumnHeaders.Add , , "Course" ' Column 3
- ListView2.ColumnHeaders.Add , , "Race Type" ' Column 4
- ListView2.ColumnHeaders.Add , , "Distance" ' Column 5
- ListView2.ColumnHeaders.Add , , "Going" ' Column 6
- ListView2.ColumnHeaders.Add , , "Time" ' Column 7
- ListView2.ColumnHeaders.Add , , "Position" ' Column 8
- ListView2.ColumnHeaders.Add , , "Runners" ' Column 9
- ListView2.ColumnHeaders.Add , , "BTN" ' Column 10
- ListView2.ColumnHeaders.Add , , "Class" ' Column 11
- ListView2.ColumnHeaders.Add , , "WGT" ' Column 12
- ListView2.ColumnHeaders.Add , , "OR" ' Column 13
- ListView2.ColumnHeaders.Add , , "RPR" ' Column 14
- ListView2.ColumnHeaders.Add , , "HG" ' Column 15
- ListView2.ColumnHeaders.Add , , "Draw" ' Column 16
- ListView2.ColumnHeaders.Add , , "No." ' Column 17
- ListView2.ColumnHeaders.Add , , "Jockey" ' Column 18
- ListView2.ColumnHeaders.Add , , "Prize" ' Column 19
- ListView2.ColumnHeaders.Add , , "Comments" ' Column 20
- Me.ListView1.Gridlines = True
- End Sub
- Private Sub UserForm_Initialize()
- ' Import racecard CSV data into a new sheet
- Dim newSheet As Worksheet
- Set newSheet = Workbooks("RaceCardAnalyser.xlsm").Worksheets.Add
- With newSheet.QueryTables.Add(Connection:= _
- "TEXT;D:\Racecard Analysis Project\Racecards\racecards.csv", Destination:=newSheet.Range("A1"))
- .TextFileCommaDelimiter = True 'Set delimiter to comma
- .TextFileParseType = xlDelimited
- .Refresh
- End With
- ' Import historical data CSV data into a new sheet
- Dim newSheet2 As Worksheet
- Set newSheet2 = Workbooks("RaceCardAnalyser.xlsm").Worksheets.Add
- With newSheet2.QueryTables.Add(Connection:= _
- "TEXT;D:\Racecard Analysis Project\Data\data.csv", Destination:=newSheet2.Range("A1"))
- .TextFileCommaDelimiter = True 'Set delimiter to comma
- .TextFileParseType = xlDelimited
- .Refresh
- End With
- CreateListView1ColumnHeaders
- CreateListView2ColumnHeaders
- ' Store the name of the new racecard sheet
- racecardSheetName = newSheet.Name
- ' Store the name of the new data sheet
- dataSheetName = newSheet2.Name
- ' Create dictionary to store racecourses and times
- Dim raceData As Object
- Set raceData = CreateObject("Scripting.Dictionary")
- ' Loop through all rows of data
- Dim currRow As Long
- For currRow = 2 To newSheet.Cells(newSheet.Rows.Count, "A").End(xlUp).Row
- ' Get current race course and race time AND horse name
- Dim raceCourse As String
- Dim raceTime As String
- Dim horseName As String
- raceCourse = newSheet.Cells(currRow, 3).value
- raceTime = Format(newSheet.Cells(currRow, 2).value, "h:mm")
- horseName = newSheet.Cells(currRow, 12).value
- ' Add race course and race time to dictionary AND horse name
- If Not raceData.Exists(raceCourse) Then
- raceData.Add raceCourse, New Collection
- End If
- ' Add race time to collection if it doesn't already exist
- Dim raceTimeCheck As Collection
- Set raceTimeCheck = raceData(raceCourse)
- Dim found As Boolean
- found = False
- Dim i As Long
- For i = 1 To raceTimeCheck.Count
- If raceTimeCheck(i) = raceTime Then
- found = True
- Exit For
- ElseIf raceTimeCheck(i) > raceTime Then
- raceTimeCheck.Add raceTime, Before:=i
- found = True
- Exit For
- End If
- Next i
- If Not found Then
- raceTimeCheck.Add raceTime
- End If
- Next currRow
- ' Populate TreeView with data from dictionary
- Dim raceCourses As Variant
- For Each raceCourses In raceData
- ' Add parent node for race course
- Dim currNode As Node
- Set currNode = TreeView1.Nodes.Add(, , raceCourses, raceCourses)
- currNode.Tag = raceCourses
- ' Add child nodes for race times
- Dim raceTimes As Variant
- For Each raceTimes In raceData(raceCourses)
- Set currNode = TreeView1.Nodes.Add(raceCourses, tvwChild, , raceTimes)
- currNode.Tag = raceTimes
- Next raceTimes
- Next raceCourses
- ' Clean up
- Set newSheet = Nothing
- Set raceData = Nothing
- End Sub
- Private Sub UserForm_Terminate()
- ' NOTES: Remove the sheet created when the form was initialized
- Application.DisplayAlerts = False 'Suppress alert message
- Workbooks("RaceCardAnalyser.xlsm").Sheets(racecardSheetName).Delete
- Workbooks("RaceCardAnalyser.xlsm").Sheets(dataSheetName).Delete
- Application.DisplayAlerts = True
- End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement