"Main" module ---------------------------------------------------------------------------------------- Option Explicit Public Datalists As Collection Public Metadatas As Collection Public Sub Main() Call ShowBread Call PopulateDatalists Call PopulateMetadatas Call AddPlaceToDatalists Call AddStandardToDatalists Call AddLastChildToDatalists Call DisplayDatalists End Sub Private Function AddLastChildToDatalists() Dim i As Long Dim j As Long Dim hitVector() As Variant ReDim hitVector(1 To Metadatas.Item(1).CountDifferent(), 1 To 2) For i = 1 To Metadatas.Item(1).CountDifferent() For j = 1 To Datalists.Count If Datalists.Item(j).Grouping = i Then hitVector(i, 1) = j hitVector(i, 2) = i End If Next j Next i For i = 1 To Metadatas.Item(1).CountDifferent() Datalists.Item(hitVector(i, 1)).LastChild = hitVector(i, 2) Next i End Function Private Function AddStandardToDatalists() Dim i As Long Dim j As Long Dim temp1 As String Dim temp2 As Double Dim endMarker As Double Dim sortBoolean As Boolean Dim sortVector() As Variant j = 0 ReDim sortVector(1 To Metadatas.Item(1).CountNotEmpty(), 1 To 3) For i = 1 To Datalists.Count If Datalists.Item(i).NotEmpty = True Then j = j + 1 sortVector(j, 1) = Datalists.Item(i).Entry sortVector(j, 2) = Datalists.Item(i).Sequence sortVector(j, 3) = 0 End If Next i endMarker = Metadatas.Item(1).CountNotEmpty() - 1 sortBoolean = True Do While sortBoolean = True sortBoolean = False For i = 1 To endMarker If sortVector(i, 1) > sortVector(i + 1, 1) Then temp1 = sortVector(i, 1) temp2 = sortVector(i, 2) sortVector(i, 1) = sortVector(i + 1, 1) sortVector(i, 2) = sortVector(i + 1, 2) sortVector(i + 1, 1) = temp1 sortVector(i + 1, 2) = temp2 sortBoolean = True End If Next i endMarker = endMarker - 1 Loop j = 1 sortVector(1, 3) = j For i = 1 To Metadatas.Item(1).CountNotEmpty() - 1 If sortVector(i, 1) = sortVector(i + 1, 1) Then sortVector(i + 1, 3) = j Else j = j + 1 sortVector(i + 1, 3) = j End If Next i For i = 1 To Metadatas.Item(1).CountNotEmpty() Datalists.Item(sortVector(i, 2)).Grouping = sortVector(i, 3) Next i End Function Private Function AddPlaceToDatalists() Dim i As Long Dim j As Long Dim temp1 As String Dim temp2 As Double Dim endMarker As Double Dim sortBoolean As Boolean Dim sortVector() As Variant j = 0 ReDim sortVector(1 To Metadatas.Item(1).CountNotEmpty(), 1 To 2) For i = 1 To Datalists.Count If Datalists.Item(i).NotEmpty = True Then j = j + 1 sortVector(j, 1) = Datalists.Item(i).Entry sortVector(j, 2) = Datalists.Item(i).Sequence End If Next i endMarker = Metadatas.Item(1).CountNotEmpty() - 1 sortBoolean = True Do While sortBoolean = True sortBoolean = False For i = 1 To endMarker If sortVector(i, 1) > sortVector(i + 1, 1) Then temp1 = sortVector(i, 1) temp2 = sortVector(i, 2) sortVector(i, 1) = sortVector(i + 1, 1) sortVector(i, 2) = sortVector(i + 1, 2) sortVector(i + 1, 1) = temp1 sortVector(i + 1, 2) = temp2 sortBoolean = True End If Next i endMarker = endMarker - 1 Loop For i = 1 To Metadatas.Item(1).CountNotEmpty() Datalists.Item(sortVector(i, 2)).Place = i Next i End Function Public Function PopulateMetadatas() Set Metadatas = New Collection Dim m As Metadata Set m = New Metadata Metadatas.Add m End Function Public Function PopulateDatalists() Dim i As Long Dim d As Datalist Set Datalists = New Collection Worksheets("Blad1").Activate i = 0 Do i = i + 1 Set d = New Datalist Datalists.Add d Datalists.Item(i).Sequence = i Datalists.Item(i).Entry = Cells(i, 1).Value Datalists.Item(i).IsNotEmpty Datalists.Item(i).Place = 0 Datalists.Item(i).Grouping = 0 Datalists.Item(i).LastChild = 0 Loop While Datalists.Item(i).Entry <> "CCCDDD" Datalists.Remove (i) End Function Public Function DisplayDatalists() Dim i As Long Worksheets("Blad2").Activate ActiveSheet.Cells.Clear For i = 1 To Datalists.Count Cells(i, 1).Value = Datalists.Item(i).Sequence Cells(i, 2).Value = Datalists.Item(i).Entry Cells(i, 3).Value = Datalists.Item(i).NotEmpty Cells(i, 4).Value = Datalists.Item(i).Place Cells(i, 5).Value = Datalists.Item(i).Grouping Cells(i, 6).Value = Datalists.Item(i).LastChild Cells(i, 7).Value = Datalists.Item(i).Keeper Next i End Function Public Function ShowBread() Dim i As Long Dim vBread(1 To 29) As String vBread(1) = "" vBread(2) = "nor" vBread(3) = "" vBread(4) = "" vBread(5) = "norflox" vBread(6) = "" vBread(7) = "" vBread(8) = "cip" vBread(9) = "cipr" vBread(10) = "" vBread(11) = "" vBread(12) = "cipro" vBread(13) = "" vBread(14) = "" vBread(15) = "ciproflox" vBread(16) = "" vBread(17) = "cipr" vBread(18) = "" vBread(19) = "norfloxa" vBread(20) = "" vBread(21) = "noorflox" vBread(22) = "cipro" vBread(23) = "" vBread(24) = "" vBread(25) = "ciproflox" vBread(26) = "nor" vBread(27) = "" vBread(28) = "" vBread(29) = "CCCDDD" Worksheets("Blad1").Activate ActiveSheet.Cells.Clear For i = LBound(vBread) To UBound(vBread) Cells(i, 1).Value = vBread(i) Next i End Function "Datalist" class module -------------------------------------------------------------------------------------- Option Explicit Public Sequence As Double Public Entry As String Public NotEmpty As Boolean Public Place As Double Public Grouping As Double Public LastChild As Double Public Keeper As Boolean Private Sub Class_Initialize() Me.Sequence = 0 Me.Entry = "" Me.NotEmpty = False Me.Place = 0 Me.Grouping = 0 Me.LastChild = 0 Me.Keeper = False End Sub Public Sub IsNotEmpty() If Me.Entry <> "" Then Me.NotEmpty = True End If End Sub "Metadata" class module -------------------------------------------------------------------------------------- Option Explicit Public Function CountNotEmpty() Dim i As Long Dim j As Double j = 0 For i = 1 To Datalists.Count If Datalists.Item(i).NotEmpty = True Then j = j + 1 End If Next i CountNotEmpty = j End Function Public Function CountDifferent() Dim i As Long Dim j As Double j = 0 For i = 1 To Datalists.Count If Datalists.Item(i).Grouping > j Then j = Datalists.Item(i).Grouping End If Next i CountDifferent = j End Function "Blad3" workbook code-behind -------------------------------------------------------------------------------------- Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) Call DoThings(ActiveCell.Row, ActiveCell.Column) End Sub "Main Graphics" module -------------------------------------------------------------------------------------- Option Explicit Public Datasheets As Collection Public Datacells As Collection Public Sub Main() Dim i As Long Dim j As Long Set Datasheets = New Collection Set Datacells = New Collection Dim ds As Datasheet Set ds = New Datasheet Datasheets.Add ds Call Datasheets.Item(1).Clear_GUI Call Datasheets.Item(1).Create_Datacells Call Datasheets.Item(1).Upgrade_Datacells End Sub Public Sub DoThings(ByVal value1 As Double, ByVal value2 As Double) Dim i As Long Dim j As Long Dim hit As Boolean Dim index As Double Dim indexRowMin As Double Dim indexRowMax As Double index = Datasheets.Item(1).Find_Cell_Index(value1, value2) If index > 0 Then If Datacells.Item(index).ColorName = Datasheets.Item(1).GrayColorName Then indexRowMin = Datasheets.Item(1).Find_Lowest_Index_On_This_Row(value1) indexRowMax = Datasheets.Item(1).Find_Highest_Index_On_This_Row(value1) For i = indexRowMin To indexRowMax Datacells.Item(i).Set_Gray Next i Call Datacells.Item(index).Set_No ElseIf Datacells.Item(index).ColorName = Datasheets.Item(1).NoColorName Then indexRowMin = Datasheets.Item(1).Find_Lowest_Index_On_This_Row(value1) indexRowMax = Datasheets.Item(1).Find_Highest_Index_On_This_Row(value1) For i = indexRowMin To indexRowMax Datacells.Item(i).Set_Gray Next i End If End If For i = 1 To Datacells.Count If Datacells.Item(i).Purpose = Datasheets.Item(1).PurposeHeader Then Datacells.Item(i).Set_Red End If Next i For i = 1 To Datacells.Count If Datacells.Item(i).ColorName = Datasheets.Item(1).NoColorName Then For j = 1 To Datacells.Count If Datacells.Item(j).Purpose = Datasheets.Item(1).PurposeHeader Then If Datacells.Item(j).SheetRow = Datacells.Item(i).SheetRow Or Datacells.Item(j).SheetCol = Datacells.Item(i).SheetCol Then Datacells.Item(j).Set_Green End If End If Next j End If Next i hit = False For i = 1 To Datacells.Count If Datacells.Item(i).ColorName = Datasheets.Item(1).RedColorName Then hit = True End If If hit = False Then Datacells.Item(1).Content = Datasheets.Item(1).MatchContent Else Datacells.Item(1).Content = "" End If Next i Call Datasheets.Item(1).Upgrade_Datacells End Sub "Datacell" class module -------------------------------------------------------------------------------------- Option Explicit Public IsBold As Boolean Public ColorCode As Double Public ColorName As String Public Content As String Public Purpose As String Public SheetRow As Double Public SheetCol As Double Public VectorRow As Double Public VectorCol As Double Private Sub Class_Initialize() Me.IsBold = False Me.ColorCode = Datasheets.Item(1).GrayColorCode Me.ColorName = Datasheets.Item(1).GrayColorName Me.Content = Datasheets.Item(1).DefaultContent Me.Purpose = Datasheets.Item(1).PurposeGeneral Me.SheetRow = 0 Me.SheetCol = 0 Me.VectorRow = 0 Me.VectorCol = 0 End Sub Public Sub Upgrade_Screen() Cells(Me.SheetRow, Me.SheetCol).Value = Me.Content Cells(Me.SheetRow, Me.SheetCol).Font.Color = Me.ColorCode Cells(Me.SheetRow, Me.SheetCol).Font.Bold = Me.IsBold End Sub Public Sub Set_Location(ByVal value1 As Double, ByVal value2 As Double) Me.SheetRow = value1 Me.SheetCol = value2 Me.VectorRow = Me.SheetRow Me.VectorCol = Me.SheetCol End Sub Public Sub Set_Red() Me.IsBold = True Me.ColorCode = Datasheets.Item(1).RedColorCode Me.ColorName = Datasheets.Item(1).RedColorName End Sub Public Sub Set_Blue() Me.IsBold = False Me.ColorCode = Datasheets.Item(1).BlueColorCode Me.ColorName = Datasheets.Item(1).BlueColorName End Sub Public Sub Set_Green() Me.IsBold = False Me.ColorCode = Datasheets.Item(1).GreenColorCode Me.ColorName = Datasheets.Item(1).GreenColorName End Sub Public Sub Set_Gray() Me.IsBold = False Me.ColorCode = Datasheets.Item(1).GrayColorCode Me.ColorName = Datasheets.Item(1).GrayColorName End Sub Public Sub Set_Gold() Me.IsBold = False Me.ColorCode = Datasheets.Item(1).GoldColorCode Me.ColorName = Datasheets.Item(1).GoldColorName End Sub Public Sub Set_No() Me.IsBold = False Me.ColorCode = Datasheets.Item(1).NoColorCode Me.ColorName = Datasheets.Item(1).NoColorName End Sub "Datasheet" class module -------------------------------------------------------------------------------------- Option Explicit Public WS As String Public Home As String Public RowMin As Double Public ColMin As Double Public RowMax As Double Public ColMax As Double Public ActiveRowMin As Double Public ActiveColMin As Double Public RedColorCode As Double Public BlueColorCode As Double Public GreenColorCode As Double Public GrayColorCode As Double Public GoldColorCode As Double Public NoColorCode As Double Public RedColorName As String Public BlueColorName As String Public GreenColorName As String Public GrayColorName As String Public GoldColorName As String Public NoColorName As String Public DefaultContent As String Public MatchContent As String Public PurposeOrigo As String Public PurposeHeader As String Public PurposeGeneral As String Private Sub Class_Initialize() Me.WS = "Blad3" Me.Home = "A1" Me.RowMin = 1 Me.ColMin = 1 Me.RowMax = 15 Me.ColMax = 5 Me.ActiveRowMin = 2 Me.ActiveColMin = 2 Me.RedColorCode = 238 Me.BlueColorCode = 16741960 Me.GreenColorCode = 1343536 Me.GrayColorCode = 14408667 Me.GoldColorCode = 962030 Me.NoColorCode = 0 Me.RedColorName = "Red" Me.BlueColorName = "Blue" Me.GreenColorName = "Green" Me.GrayColorName = "Gray" Me.GoldColorName = "Gold" Me.NoColorName = "No" Me.DefaultContent = "*" Me.MatchContent = "MATCH" Me.PurposeOrigo = "Origo" Me.PurposeHeader = "Header" Me.PurposeGeneral = "General" End Sub Public Sub Clear_GUI() Worksheets(Me.WS).Activate ActiveSheet.Cells.Clear End Sub Public Sub Create_Datacells() Dim i As Long Dim j As Long Dim dc As Datacell For i = 1 To Me.RowMax For j = 1 To Me.ColMax Set dc = New Datacell Datacells.Add dc Call Datacells.Item(Datacells.Count).Set_Location(i, j) Next j Next i For i = 1 To Datacells.Count If Datacells.Item(i).SheetRow = 1 And Datacells.Item(i).SheetCol = 1 Then Datacells.Item(i).Purpose = Me.PurposeOrigo Datacells.Item(i).Content = "" Call Datacells.Item(i).Set_Gold ElseIf Datacells.Item(i).SheetRow = 1 And Datacells.Item(i).SheetCol >= Me.ActiveColMin Then Datacells.Item(i).Purpose = Me.PurposeHeader Call Datacells.Item(i).Set_Red ElseIf Datacells.Item(i).SheetCol = 1 And Datacells.Item(i).SheetRow >= Me.ActiveRowMin Then Datacells.Item(i).Purpose = Me.PurposeHeader Call Datacells.Item(i).Set_Red End If Next i End Sub Public Sub Upgrade_Datacells() Dim i As Long For i = 1 To Datacells.Count Call Datacells.Item(i).Upgrade_Screen Next i End Sub Public Function Find_Cell_Index(ByVal value1 As Double, ByVal value2 As Double) As Double Dim i As Long If value1 >= Me.ActiveRowMin And value1 <= Me.RowMax And value2 >= Me.ActiveColMin And value2 <= Me.ColMax Then For i = 1 To Datacells.Count If Datacells.Item(i).SheetRow = value1 And Datacells.Item(i).SheetCol = value2 Then Find_Cell_Index = i End If Next i Else Find_Cell_Index = 0 End If End Function Public Function Find_Lowest_Index_On_This_Row(ByVal value1 As Double) As Double Dim i As Long For i = 1 To Datacells.Count If Datacells.Item(i).SheetRow = value1 And Datacells.Item(i).SheetCol = Me.ActiveColMin Then Find_Lowest_Index_On_This_Row = i End If Next i End Function Public Function Find_Highest_Index_On_This_Row(ByVal value1 As Double) As Double Dim i As Long For i = 1 To Datacells.Count If Datacells.Item(i).SheetRow = value1 And Datacells.Item(i).SheetCol = Me.ColMax Then Find_Highest_Index_On_This_Row = i End If Next i End Function "Main" module -------------------------------------------------------------------------------------- Option Explicit Public Definitions As Collection Public States As Dictionary Public DataPoints As Collection Public Sub Main() Dim i As Long Dim j As Long Set Definitions = New Collection Dim d As Definition Set d = New Definition Definitions.Add d Call Create_States Worksheets("Blad1").Activate ActiveSheet.Cells.Clear Set DataPoints = New Collection Dim dp As DataPoint For i = 1 To 10 For j = 1 To 10 Set dp = New DataPoint DataPoints.Add dp Call DataPoints.Item(DataPoints.Count).Set_DataPoint(DataPoints.Count, i, j, "*", Definitions.Item(1).GeneralOff) Next j Next i Call Display_DataPoints End Sub Public Sub Create_States() Set States = New Dictionary Dim s1 As State Set s1 = New State States.Add Definitions.Item(1).OrigoOn, s1 Dim s2 As State Set s2 = New State States.Add Definitions.Item(1).OrigoOff, s2 Dim s3 As State Set s3 = New State States.Add Definitions.Item(1).HorizontalHeaderOn, s3 Dim s4 As State Set s4 = New State States.Add Definitions.Item(1).HorizontalHeaderOff, s4 Dim s5 As State Set s5 = New State States.Add Definitions.Item(1).VerticalHeaderOn, s5 Dim s6 As State Set s6 = New State States.Add Definitions.Item(1).VerticalHeaderOff, s6 Dim s7 As State Set s7 = New State States.Add Definitions.Item(1).GeneralOn, s7 Dim s8 As State Set s8 = New State States.Add Definitions.Item(1).GeneralOff, s8 States.Item(Definitions.Item(1).OrigoOn).Set_OrigoOn States.Item(Definitions.Item(1).OrigoOff).Set_OrigoOff States.Item(Definitions.Item(1).HorizontalHeaderOn).Set_HorizontalHeaderOn States.Item(Definitions.Item(1).HorizontalHeaderOff).Set_HorizontalHeaderOff States.Item(Definitions.Item(1).VerticalHeaderOn).Set_VerticalHeaderOn States.Item(Definitions.Item(1).VerticalHeaderOff).Set_VerticalHeaderOff States.Item(Definitions.Item(1).GeneralOn).Set_GeneralOn States.Item(Definitions.Item(1).GeneralOff).Set_GeneralOff End Sub Public Sub Display_DataPoints() Dim i As Long For i = 1 To DataPoints.Count With Cells(DataPoints.Item(i).RowNumber, DataPoints.Item(i).ColumnNumber) .Value = DataPoints.Item(i).Content .Font.Color = States.Item(DataPoints.Item(i).PurposeState).ColorCode .Font.Bold = States.Item(DataPoints.Item(i).PurposeState).IsBold End With Next i End Sub "DataPoint" class module -------------------------------------------------------------------------------------- Option Explicit Public Index As Double Public ColumnNumber As Long Public RowNumber As Long Public Content As String Public PurposeState As String Private Sub Class_Initialize() Me.Index = 0 Me.ColumnNumber = 0 Me.RowNumber = 0 Me.Content = Definitions.Item(1).Content Me.PurposeState = Definitions.Item(1).GeneralOff End Sub Public Sub Set_DataPoint(ByVal value1 As Double, ByVal value2 As Long, ByVal value3 As Long, ByVal value4 As String, ByVal value5 As String) Me.Index = value1 Me.RowNumber = value2 Me.ColumnNumber = value3 Me.Content = value4 Me.PurposeState = value5 End Sub "Definition" class module -------------------------------------------------------------------------------------- Option Explicit Public RedCode As Double Public BlueCode As Double Public GreenCode As Double Public GrayCode As Double Public GoldCode As Double Public BlackCode As Double Public RedName As String Public BlueName As String Public GreenName As String Public GrayName As String Public GoldName As String Public BlackName As String Public Origo As String Public HorizontalHeader As String Public VerticalHeader As String Public General As String Public StateOn As String Public StateOff As String Public OrigoOn As String Public OrigoOff As String Public HorizontalHeaderOn As String Public HorizontalHeaderOff As String Public VerticalHeaderOn As String Public VerticalHeaderOff As String Public GeneralOn As String Public GeneralOff As String Public Content As String Private Sub Class_Initialize() Me.RedCode = 238 Me.BlueCode = 16741960 Me.GreenCode = 1343536 Me.GrayCode = 14408667 Me.GoldCode = 962030 Me.BlackCode = 0 Me.RedName = "Red" Me.BlueName = "Blue" Me.GreenName = "Green" Me.GrayName = "Gray" Me.GoldName = "Gold" Me.BlackName = "Black" Me.Origo = "Origo" Me.HorizontalHeader = "HorizontalHeader" Me.VerticalHeader = "VerticalHeader" Me.General = "General" Me.StateOn = "On" Me.StateOff = "Off" Me.OrigoOn = "OrigoOn" Me.OrigoOff = "OrigoOffName" Me.HorizontalHeaderOn = "HorizontalHeaderOn" Me.HorizontalHeaderOff = "HorizontalHeaderOff" Me.VerticalHeaderOn = "VerticalHeaderOn" Me.VerticalHeaderOff = "VerticalHeaderOff" Me.GeneralOn = "GeneralOn" Me.GeneralOff = "GeneralOff" Me.Content = "*" End Sub "State" class module -------------------------------------------------------------------------------------- Option Explicit Public IsBold As Boolean Public ColorCode As Double Public ColorName As String Public Purpose As String Public State As String Public PurposeState As String Public Content As String Private Sub Class_Initialize() Me.IsBold = False Me.ColorCode = Definitions.Item(1).GrayCode Me.ColorName = Definitions.Item(1).GrayName Me.Purpose = Definitions.Item(1).General Me.State = Definitions.Item(1).StateOff Me.PurposeState = Definitions.Item(1).GeneralOff Me.Content = Definitions.Item(1).Content End Sub Public Sub Set_OrigoOn() Me.IsBold = False Me.ColorCode = Definitions.Item(1).GoldCode Me.ColorName = Definitions.Item(1).GoldName Me.Purpose = Definitions.Item(1).Origo Me.State = Definitions.Item(1).StateOn Me.PurposeState = Definitions.Item(1).OrigoOn End Sub Public Sub Set_OrigoOff() Me.IsBold = False Me.ColorCode = Definitions.Item(1).GoldCode Me.ColorName = Definitions.Item(1).GoldName Me.Purpose = Definitions.Item(1).Origo Me.State = Definitions.Item(1).StateOff Me.PurposeState = Definitions.Item(1).OrigoOff End Sub Public Sub Set_HorizontalHeaderOn() Me.IsBold = False Me.ColorCode = Definitions.Item(1).GreenCode Me.ColorName = Definitions.Item(1).GreenName Me.Purpose = Definitions.Item(1).HorizontalHeader Me.State = Definitions.Item(1).StateOn Me.PurposeState = Definitions.Item(1).HorizontalHeaderOn End Sub Public Sub Set_HorizontalHeaderOff() Me.IsBold = True Me.ColorCode = Definitions.Item(1).RedCode Me.ColorName = Definitions.Item(1).RedName Me.Purpose = Definitions.Item(1).HorizontalHeader Me.State = Definitions.Item(1).StateOff Me.PurposeState = Definitions.Item(1).HorizontalHeaderOff End Sub Public Sub Set_VerticalHeaderOn() Me.IsBold = False Me.ColorCode = Definitions.Item(1).GreenCode Me.ColorName = Definitions.Item(1).GreenName Me.Purpose = Definitions.Item(1).VerticalHeader Me.State = Definitions.Item(1).StateOn Me.PurposeState = Definitions.Item(1).VerticalHeaderOn End Sub Public Sub Set_VerticalHeaderOff() Me.IsBold = True Me.ColorCode = Definitions.Item(1).RedCode Me.ColorName = Definitions.Item(1).RedName Me.Purpose = Definitions.Item(1).VerticalHeader Me.State = Definitions.Item(1).StateOff Me.PurposeState = Definitions.Item(1).VerticalHeaderOff End Sub Public Sub Set_GeneralOn() Me.IsBold = False Me.ColorCode = Definitions.Item(1).BlackCode Me.ColorName = Definitions.Item(1).BlackName Me.Purpose = Definitions.Item(1).General Me.State = Definitions.Item(1).StateOn Me.PurposeState = Definitions.Item(1).GeneralOn End Sub Public Sub Set_GeneralOff() Me.IsBold = False Me.ColorCode = Definitions.Item(1).GrayCode Me.ColorName = Definitions.Item(1).GrayName Me.Purpose = Definitions.Item(1).General Me.State = Definitions.Item(1).StateOff Me.PurposeState = Definitions.Item(1).GeneralOff End Sub