Code:
Private Sub Loop_Test_Equip_Click()
Dim db As DAO.Database
Dim rS As DAO.Recordset, HB As DAO.Recordset, rST As Recordset
Dim CtrPlat As Integer, CtrMEquip As Integer, CtrDisMEquip As Integer, CtrFE As Integer
Dim PlatArr As Variant, FEArr As Variant, MEquipArr As Variant, DEquipArr As Variant
Set db = CurrentDb()
Set rS = CurrentDb.OpenRecordset("SELECT [Row Type], Count(*) AS CntType FROM Table1 GROUP BY [Row Type]")
While Not rS.EOF
If rS![Row Type] = "PLAT" Then
ReDim PlatArr(1 To rS!CntType, 1 To 9)
ElseIf rS![Row Type] = "FE" Then
ReDim FEArr(1 To rS!CntType, 1 To 9)
ElseIf rS![Row Type] = "MEQUIP" Then
ReDim MEquipArr(1 To rS!CntType, 1 To 8)
ElseIf rS![Row Type] = "DISMEQUIP" Then
ReDim DEquipArr(1 To rS!CntType, 1 To 9)
End If
Wend
rS.Close
'Sets count to 0
CtrPlat = 0
CtrFE = 0
CtrMEquip = 0
CtrDisMEquip = 0
'Stores the information in an array for later use
Set rST = CurrentDb.OpenRecordset("Table1")
Do While Not rST.EOF
rST.Edit
'Mounted Equipment
If rST![Row Type] = "MEQUIP" Then
CtrMEquip = CtrMEquip + 1
MEquipArr(CtrMEquip, 1) = rS![unique_id] 'Unique_ID
MEquipArr(CtrMEquip, 2) = rS![Equip HB Name] 'HB Name
If rS![Networks] <> "" Then
MEquipArr(CtrMEquip, 3) = "[" & rST![Networks] & "]" 'Assigned Network
End If
If rS![parent_equipment_item_id] = rST![platform_id] Then 'parent_equipment and platform ID's are the same, it's not needed, Node ID maps to the Platform
MEquipArr(CtrMEquip, 4) = ""
Else: MEquipArr(CtrMEquip, 4) = rST![parent_equipment_item_id]
End If
MEquipArr(CtrMEquip, 5) = rST![materiel_shading] 'Materiel shading color
MEquipArr(CtrMEquip, 6) = rST![materiel_text_coloring] 'Materiel text color
MEquipArr(CtrMEquip, 7) = rST![platform_id] 'platform_id
'Pesonnel
ElseIf rST![Row Type] = "FE" Then
CtrFE = CtrFE + 1
FEArr(CtrFE, 1) = rST![(Role / FE / Node ID] 'VisioID will be NodeID
FEArr(CtrFE, 2) = rST![Unit] '(BN) Unit
FEArr(CtrFE, 3) = rST![TOE Title] '(CO) TOE Title
FEArr(CtrFE, 4) = rST![Para Desc] '(PLT/SEC) Para Desc
FEArr(CtrFE, 5) = rST![Role / FE Rank] 'Rank
FEArr(CtrFE, 6) = rST![Role / FE MOS] 'Role
If rST![Equip HB Name] = "." Then 'if equipment name is a period then its a Soldier
FEArr(CtrFE, 7) = "Soldier"
Else: FEArr(CtrFE, 7) = rST![Equip HB Name] 'HB Name
End If
FEArr(CtrFE, 8) = rST![Bumper # / Plat ID] 'Bumper #
FEArr(CtrFE, 9) = rST![platform_shading] 'Platform Shading
'Vehicles
ElseIf rST![Row Type] = "PLAT" Then
CtrPlat = CtrPlat + 1
PlatArr(CtrPlat, 1) = rST![Parent Node ID] & "-" & rS![platform_id] 'Node_ID-Platform_ID
PlatArr(CtrPlat, 2) = rST![Unit] '(BN) Unit
PlatArr(CtrPlat, 3) = rST![TOE Title] '(CO) TOE Title
PlatArr(CtrPlat, 4) = rST![Para Desc] '(PLT/SEC) Para Desc
PlatArr(CtrPlat, 5) = rST![Role / FE MOS] 'Role
PlatArr(CtrPlat, 6) = rST![Role / FE Rank] 'Rank
PlatArr(CtrPlat, 7) = rST![Equip HB Name] '(Platform type) Equip HB name
PlatArr(CtrPlat, 8) = rST![Bumper # / Plat ID] 'Bumper #
PlatArr(CtrPlat, 9) = rST![platform_shading] 'Platform Shading
'Dismounted Equipment
ElseIf rST![Row Type] = "DISMEQUIP" Then
CtrDisMEquip = CtrDisMEquip + 1
DEquipArr(CtrDisMEquip, 1) = rST![unique_id] 'Unique_ID
DEquipArr(CtrDisMEquip, 2) = rST![Equip HB Name] 'HB Name
If rS![Networks] <> "" Then
MEquipArr(CtrMEquip, 3) = "[" & rST![Networks] & "]" 'Assigned Network
End If
DEquipArr(CtrDisMEquip, 4) = rST![parent_equipment_item_id] 'Parent_equipment_ID
DEquipArr(CtrDisMEquip, 5) = rST![materiel_shading] 'Materiel shading color
DEquipArr(CtrDisMEquip, 6) = rST![materiel_text_coloring] 'Materiel text color
DEquipArr(CtrDisMEquip, 7) = rST![Role / FE / Node ID] 'Node ID
End If
rST.MoveNext
Loop
rST.Close
Dim MntdGrp As Collection 'list of different Platform IDs for Mounted equipment
Dim DisMtdGrp As Collection 'list of different Node IDs for Dismounted equipment
Dim CtrGrp As Integer, R As Integer
Set MntdGrp = New Collection
Set DisMtdGrp = New Collection
MntdGrp.Add MEquipArr(1, 7) 'platform_id
CtrGrp = 1
For R = 1 To CtrMEquip
If MEquipArr(R, 7) <> MntdGrp(CtrGrp) Then
MntdGrp.Add MEquipArr(R, 7)
CtrGrp = CtrGrp + 1
End If
Next R
DisMtdGrp.Add DEquipArr(1, 7) 'Node_id
CtrGrp = 1
For R = 1 To CtrDisMEquip
If DEquipArr(R, 7) <> DisMtdGrp(CtrGrp) Then
DisMtdGrp.Add DEquipArr(R, 7)
CtrGrp = CtrGrp + 1
End If
Next R
Dim HBArr As Variant, PlatSys As Variant
Dim PlatItem As Object, BaseItem As Object
Dim SubEquipItem As Object, PlatAlignItem As Object
Dim PlatEquip As Collection, PlatAlignEquip As Collection 'list of all equipment that belongs to a Platform system 'Collects all the data into 1 array where the info aligns by platform
Dim PlatBaseEquip As Collection, PlatSubEquip As Collection 'list of equipment aligned in chronological order (parent-kid-g_kid-g_g_kid) to a Platform system 'subset of PlatBaseEquip who are siblings
Dim RowNum As Integer, RowEquip As Integer, CtrG As Integer
Dim ColNum As Integer, SubItemKey As Integer, ParKey As Integer
Dim RowSubEquip As Integer, RowLastSub As Integer
Dim RowSub As Integer, PlatKey As Integer, PlatBaseEquipKey As Integer
Dim EquipValue As String, ParID() As String, PlatEquipSplit() As String
Dim ParExists As String, SubEquipSplit As String, strVal As String
Dim PlatBaseEquipSplit() As String, SubItemSplit() As String
Set PlatEquip = New Collection 'list of all equipment that belongs to a Platform system
Set PlatBaseEquip = New Collection 'list of equipment aligned in chronological order (parent-kid-g_kid-g_g_kid) to a Platform system
Set PlatSubEquip = New Collection
Set PlatAlignEquip = New Collection
ReDim HBArr(1 To MntdGrp.Count + DisMtdGrp.Count, 1 To 44)
RowNum = 1 'Platform array counter, to not start from the begining of each loop
RowEquip = 1 'equip_arr counter to not start from the begining of each loop
CtrG = 0 'Tracks rows for the HBArr by grouped equipment counts
For Each PlatSys In MntdGrp 'Each Mounted equipment group is a row in the HBArr
For R = RowNum To CtrPlat 'Loop to get the Platform assigned to the Mounted equipment group and build out each column in the new_HB_arr
If PlatSys = CDbl(Split(PlatArr(R, 1), "-")(1)) Then 'if Mounted equip platform_id = platform_id then
RowNum = R 'this is so you dont start at the begining of the Platform array. Because of sorting, the data is in chronological order.
CtrG = CtrG + 1 'this is to keep track of the row counts (grouped equipment totals)for the new HB array.
HBArr(CtrG, 1) = PlatArr(R, 1) 'Visio ID which is NodeID-PlatID
HBArr(CtrG, 2) = PlatArr(R, 2) '(BN) Unit
HBArr(CtrG, 3) = PlatArr(R, 3) '(CO) TOE Title
HBArr(CtrG, 4) = PlatArr(R, 4) '(PLT/SEC) Para Desc
HBArr(CtrG, 5) = PlatArr(R, 5) & " " & PlatArr(R, 8) & ";;" & PlatArr(R, 9) 'Role Bumper#;;Platform_shading
HBArr(CtrG, 6) = PlatArr(R, 7) 'Platform_System_type
For RowSubEquip = RowEquip To DEquipArr 'Loop the MEquipArr to get assigned equipment to its row in the new_HB_arr
If MEquipArr(RowSubEquip, 7) = PlatSys Then 'if Node_id's are the same because there are some equipment not linked to a Platform
If RowSubEquip < DEquipArr Then
If MEquipArr(RowSubEquip + 1, 7) = PlatSys Then
RowLastSub = RowSubEquip + 1
If RowLastSub < DEquipArr Then
While MEquipArr(RowLastSub, 7) = PlatSys And (RowLastSub + 1) < DEquipArr 'gets all of rows in MEquipArr for this Platform
RowLastSub = RowLastSub + 1
Wend
RowLastSub = RowLastSub - 1 'this is due to the loop goes one over... No Do Until or Do While will not correct this
End If
Else: RowLastSub = RowSubEquip 'sets RowLastSub when there is only one piece of equipment linked to the platform
End If
Else: RowLastSub = RowSubEquip 'sets RowLastSub when on the last equipment in the M_equip_list
End If
For RowSub = RowSubEquip To RowLastSub 'EquipValue is Name;Network;fill_color;font_color
EquipValue = MEquipArr(RowSub, 2) & ";" & MEquipArr(RowSub, 3) & ";" & MEquipArr(RowSub, 5) & ";" & MEquipArr(RowSub, 6) 'Name;Network;fill_color;font_color
PlatEquip.Add CDbl(MEquipArr(RowSub, 1)) & ";" & (MEquipArr(RowSub, 4)) & ";" & EquipValue
Next RowSub
PlatKey = 1 'tracks key value needed to remove item from PlatEquip collection
Do While PlatEquip.Count <> 0 And PlatKey <= PlatEquip.Count 'this loop puts all equipment WITHOUT a parent_id into the PlatBaseEquip
ParID = Split(PlatEquip(PlatKey), ";")
If ParID(1) = "" Then 'if no parent_id you're a parent
PlatBaseEquip.Add PlatEquip(PlatKey) & ";0" 'add to new list. the ";0" is the indent value for Visio
PlatEquip.Remove (PlatKey) 'remove from old list
Else: PlatKey = PlatKey + 1 'go to next item in PlatEquip list
End If
Loop
PlatKey = 1
Do While PlatEquip.Count <> 0 And PlatKey <= PlatEquip.Count 'this loop puts all equipment WITH a parent_id into the PlatBaseEquip
PlatBaseEquipSplit = Split(PlatEquip(PlatKey), ";")
ParExists = False
PlatBaseEquipKey = 1 'Key for parents position and reset when looking at a new item from PlatEquip.
For Each PlatItem In PlatBaseEquip 'Loop gets parent's key position from PlatBaseEquip
PlatBaseEquipSplit = Split(BaseItem, ";")
If PlatEquipSplit(1) = PlatBaseEquipSplit(0) Then 'if parent_ID from PlatEquip = unique_id from PlatBaseEquip
ParKey = PlatBaseEquipKey 'Assigns parents position, but changes for each sibling.
ParExists = True
Exit For
End If
PlatBaseEquipKey = PlatBaseEquipKey + 1
Next PlatItem
If ParExists = True Then
SubItemKey = 1 'Key is for the Sub-equipment loop
For Each BaseItem In PlatEquip 'loop puts the item and its siblings into Plat_sub_equip collection
SubItemSplit = Split(SubEquipItem, ";")
If PlatEquipSplit(1) = SubItemSplit(1) Then
PlatSubEquip.Add BaseItem 'add to sub list
PlatEquip.Remove (SubItemKey) 'remove from old list
SubItemKey = SubItemKey - 1
End If
SubItemKey = SubItemKey + 1
Next BaseItem
For Each SubEquipItem In PlatSubEquip
PlatBaseEquip.Add BaseItem & ";" & PlatBaseEquipSplit(6) + 1, after:=ParKey 'add After your parent and siblings. Indent value = your_parent + 1
ParKey = ParKey + 1 'this adds siblings sequentially
Next SubEquipItem
PlatKey = 1 'reset key
Else: PlatKey = PlatKey + 1 'if parent doesn't exist, move to the next item or else move because of a data error
End If
Loop
ColNum = 7 'insert PlatBaseEquip to correct cell position of HBArr
For Each PlatAlignItem In PlatAlignEquip
strVal = Split(PlatAlignItem, ";") 'Name & Network;fill_color;font_color;indent_value
EquipValue = PlatAlignItem(2) & " " & PlatAlignItem(3) & ";" & PlatAlignItem(4) & ";" & PlatAlignItem(5) & ";" & PlatAlignItem(6)
HBArr(CtrG, ColNum) = EquipValue
ColNum = ColNum + 1
Next PlatAlignItem
RowSubEquip = RowLastSub 'Loop counter
Else: Exit For
End If
Next RowSubEquip
RowEquip = RowSubEquip 'This is so the loop starts back where it left off
Exit For
End If
Next R
Next PlatSys
DoEvents
Set rST = Nothing
Set rS = Nothing
Set HB = Nothing
End Sub