Hello Paul,
Okay, this should be golden now. Originally in the data you posted the headers appeared unique and once a header was found the search looked for the next header. Since the header "Distance" can appear in two distinct formats, the macro now searches for multiple occurrences of a header before looking for the next one in the group. The macro is already installed ini the attached workbook. Let me know if you find anything else.
Sub GetSelections()
Dim Cell As Range
Dim Data As Variant
Dim FirstCell As Range
Dim Format As Long
Dim Group1 As Variant
Dim Group2 As Variant
Dim Group3 As Variant
Dim Header As Variant
Dim n As Long
Dim Numbers As Object
Dim RegExp As Object
Dim Text As String
Dim vArray As Variant
Dim Wks As Worksheet
Dim x As Long
Set Wks = ActiveSheet
Group1 = Array(Array("Selections", "Form Experts"), Array(1))
Group2 = Array(Array("Sky Predictor", "Early Speed", "Distance"), Array(2))
Group3 = Array(Array("SkyForm Rating", "Best Form (12mths)", "Recent Form", "Distance", "Class", "Time Rating", "Start Type", "Best Overall"), Array(3))
Set Numbers = CreateObject("Scripting.Dictionary")
Set RegExp = CreateObject("VBScript.RegExp")
For Each Group In Array(Group1, Group2, Group3)
Format = Group(1)(0)
For x = 0 To UBound(Group(0))
Header = Group(0)(x)
Set Cell = Wks.Cells.Find(Header & "*", , xlValues, xlPart, xlByRows, xlNext, False, False, False)
If Not Cell Is Nothing Then
Set FirstCell = Cell
ParseData:
Do
n = n + 1
Text = Cell.Offset(n, 0).Value
Select Case Format
Case 1
RegExp.Global = True
RegExp.Pattern = "\D(\d+)\s\-.*"
Do
If Text = "" Then GoTo NextHeader
Set Matches = RegExp.Execute(Text & "-")
If Matches.Count = 0 Then Exit Do
Data = Val(Matches(0).SubMatches(0))
Text = Right(Text, Len(Text) - (Matches(0).FirstIndex + Len(Data) + 1))
If Not Numbers.Exists(Data) Then Numbers.Add Data, ""
Loop
Case 2
RegExp.Global = False
RegExp.Pattern = "\d+"
If RegExp.Test(Text) = False Then GoTo NextHeader
Data = Val(Text)
If Not Numbers.Exists(Data) Then Numbers.Add Data, ""
Case 3
RegExp.Global = False
RegExp.Pattern = "(\d+)\s.*"
Set Matches = RegExp.Execute(Text)
If Matches.Count = 0 Then GoTo NextHeader
Text = Matches(0).SubMatches(0)
Data = Val(Text)
If Not Numbers.Exists(Data) Then Numbers.Add Data, ""
End Select
Loop
NextHeader:
n = 0
' Are there any more cells with this header?
Set Cell = Wks.Cells.Find(Header & "*", Cell)
If Cell.Address <> FirstCell.Address Then GoTo ParseData
End If
Next x
NextGroup:
Next Group
vArray = SortList(Numbers.Keys)
If Range("B4") <> "" Then Range("B4").End(xlDown).ClearContents
Range("B4").Resize(UBound(vArray, 1) + 1, 1).Value = Application.Transpose(vArray)
'MsgBox Join(vArray, ", ")
End Sub
Reply With Quote
