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
- Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.listItem)
- ' 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)
- ' Check if the node is a child node
- If Node.Parent <> "" Then
- ' Cancel the label edit
- Cancel = True
- End If
- 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 Node.Parent <> "" 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
- NEWPopulateChildListView horseData '************************************************************************************************
- End Sub
- Private Sub NEWPopulateChildListView(ByVal horseData As Object)
- ' Clear existing items from child ListView
- ListView2.ListItems.Clear
- ' Set the target sheet (Sheet2)
- Dim targetSheet As Worksheet
- Set targetSheet = Worksheets(dataSheetName) ' Replace "Sheet2" with the actual name of the sheet
- ' Loop through the horse names in the dictionary and retrieve matching rows from Sheet2
- Dim horseNameKey As Variant
- For Each horseNameKey In horseData.Keys
- Dim horseName As String
- horseName = CStr(horseNameKey)
- ' Find the matching rows for the current horse name
- Dim lastRow As Long
- lastRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row
- Dim matchFound As Boolean
- matchFound = False
- Dim i As Long
- For i = 2 To lastRow
- Dim horseNameSheet2 As String
- horseNameSheet2 = targetSheet.Cells(i, 22).Value ' Assuming the horse name is in the 22nd 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 first column of Sheet2
- ' Add additional subitems if needed
- listItem.SubItems(1) = targetSheet.Cells(i, 22).Value ' Column 2
- listItem.SubItems(2) = targetSheet.Cells(i, 3).Value ' Column 3
- listItem.SubItems(3) = targetSheet.Cells(i, 5).Value ' Column 4
- listItem.SubItems(4) = targetSheet.Cells(i, 13).Value ' Column 5
- listItem.SubItems(5) = targetSheet.Cells(i, 15).Value ' Column 6
- 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
- matchFound = True ' Set the flag to indicate a match was found
- End If
- Next i
- ' Check if any matching data was found for the current horse name
- If Not matchFound Then
- MsgBox "No matching data found for horse name: " & horseName, vbInformation
- End If
- Next horseNameKey
- 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 PopulateChildListView(horseName As String)
- ' Clear existing items from parent ListView
- ListView2.ListItems.Clear
- ' 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
- ' 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
- ' Add additional subitems if needed
- listItem.SubItems(1) = targetSheet.Cells(i, 22).Value ' Column 2
- listItem.SubItems(2) = targetSheet.Cells(i, 3).Value ' Column 3
- listItem.SubItems(3) = targetSheet.Cells(i, 5).Value ' Column 4
- listItem.SubItems(4) = targetSheet.Cells(i, 13).Value ' Column 5
- listItem.SubItems(5) = targetSheet.Cells(i, 15).Value ' Column 6
- 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
- matchFound = True ' Set the flag to indicate a match was found
- End If
- Next i
- ' Check if any matching data was found
- If Not matchFound Then
- MsgBox "No matching data found for horse name: " & horseName, vbInformation
- ' Clear existing items from parent ListView
- ListView2.ListItems.Clear
- End If
- 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