Creating Dynamic Scrollbars using array

[raven1124]

Hello Everyone,

Need your help with aligning the scrollbars I created as I am creating dynamic shapes that should align each scrollbars in their respective subitems

Feel free to run my code

I created two sheets for this one:
- Database
- Sheet3

Database has this content:

Owner	Role	Reporting To	Item	Start Date	End Date	Item Count	Progress
Name1	Level 1		alksdjlskaj	7/1/2018	7/31/2018	95	62
Name2	Level 2		fgdfgdgfdg	7/1/2018		30	23
Name3	Level 2		dgwwfws	7/1/2018		20	11
Name4	Level 2		Tasdaas	7/1/2018		30	13
Name5	Level 2		Osdasad	7/1/2018		15	15
Employee 1	Level 3	Name2	Quality Sub Item 1			5	4
Employee 2	Level 3	Name2	Quality Sub Item 1			5	3
Employee 3	Level 3	Name2	Quality Sub Item 2			10	6
Employee 123	Level 3	Name2	Quality Sub Item 2			10	6
Employee 4	Level 3	Name2	Quality Sub Item 4			10	10
Employee 5	Level 3	Name3	Integrity Sub Item 1			10	6
Employee 6	Level 3	Name3	Integrity Sub Item 2			10	5
Employee 7	Level 3	Name4	Training Sub Item 1			5	0
Employee 8	Level 3	Name4	Training Sub Item 2			5	2
Employee 9	Level 3	Name4	Training Sub Item 3			5	2
Employee 10	Level 3	Name4	Training Sub Item 4			5	2
Employee 11	Level 3	Name4	Training Sub Item 5			10	7
Employee 12	Level 3	Name5	OMD Sub Item 1			5	5
Employee 13	Level 3	Name5	OMD Sub Item 2			5	5
Employee 14	Level 3	Name5	OMD Sub Item 3			5	5

<tbody>
</tbody>

Sub CreateShapes()


Dim ProjectSheet As Worksheet
Set ProjectSheet = ActiveSheet


Dim SupCounter() As String
Dim SupName() As String
Dim SubItem() As String


Dim miniextraScroll As MSForms.ScrollBar


Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim counter1 As Integer
Dim counter2 As Integer
Dim counter3 As Integer


Dim asd As Integer
Dim m As Integer
Dim duplicount As Integer


Dim mfShape As Shape
Dim mfShade As Shape
'Dim qwe As Integer
'qwe = 1


x = 1
Do While Database.Cells(x, 1) <> ""
    If Database.Cells(x, 2) = "Level 2" Then
        counter1 = counter1 + 1
        ReDim Preserve SupCounter(counter1 - 1)
        SupCounter(counter1 - 1) = Database.Cells(x, 4)
        ReDim Preserve SupName(counter1 - 1)
        SupName(counter1 - 1) = Database.Cells(x, 1)
        
        'Create Shape
         Set mfShade = ProjectSheet.Shapes.AddShape(msoShapeRoundedRectangle, 10 + (counter1 - 1) * 5 * 20, 50, 75, 13)
            With mfShade
                .Name = SupCounter(counter1 - 1)
                .Line.Visible = msoFalse
                .Fill.ForeColor.RGB = RGB(54, 56, 60)
            End With
            
        Set mfShape = ProjectSheet.Shapes.AddShape(msoShapeRoundedRectangle, 10 + (counter1 - 1) * 5 * 20, 50, mfShade.Width, 13)
            With mfShape
                .Name = SupCounter(counter1 - 1) & " Shape"
                .Line.Visible = msoFalse
                .Fill.ForeColor.RGB = RGB(8, 146, 208)
            End With
        
        
            y = 1
            asd = 0
            Do While Database.Cells(y, 1) <> ""
                
                
                
                If Database.Cells(y, 2) = "Level 3" And Database.Cells(y, 3) = SupName(counter1 - 1) Then
                    counter2 = counter2 + 1
                    asd = asd + 1
                    ReDim Preserve SubItem(counter2 - 1)
                    SubItem(counter2 - 1) = Database.Cells(y, 4)
                        
                        'Mini Shapes
                        'If qwe = 1 Then
                        For m = 0 To UBound(SubItem)
                            If SubItem(m) = SubItem(counter2 - 1) Then
                                duplicount = duplicount + 1
                            Else
                            End If
                            'MsgBox ("M: " & m & "Upperbound: " & UBound(SubItem) & "Duplicount: " & duplicount)
                            
                            
                        Next m
                        
                        
                        If duplicount = 1 Then
                        Set mfShade = ProjectSheet.Shapes.AddShape(msoShapeRoundedRectangle, 10 + (counter1 - 1) * 5 * 20, Sheet3.Shapes(SupCounter(counter1 - 1)).Top + 15 * asd, 75, 7)
                        With mfShade
                            .Name = SubItem(counter2 - 1)
                            .Line.Visible = msoFalse
                            .Fill.ForeColor.RGB = RGB(54, 56, 60)
                        End With
                        End If
                        
                        Dim a As Integer
                        
                        a = WorksheetFunction.CountIf(Database.Range("D:D"), SubItem(counter2 - 1))
                        
                        
                        
                        duplicount = 0
                        
                        
                        
                        Dim MyObject As OLEObject
                        Set MyObject = ActiveSheet.OLEObjects.Add(ClassType:="Forms.ScrollBar.1")
                                With MyObject
                                    .Name = "ScrollBar" & counter1 & counter2
                                    .Height = 7
                                    .Width = 75
                                    .Top = 7 + (Sheet3.Shapes(SubItem(counter2 - 1)).Top) * (y * 0.15)
                                    .Left = Sheet3.Shapes(SupCounter(counter1 - 1)).Left
                                        With .Object
                                        .Value = 2
                                        .Max = 5
                                        .Min = 0
                                        End With
                                End With
                        
                      
                        
                
                Else
                
                End If
            
                
            
            y = y + 1
            Loop
            
    Else


    End If


x = x + 1
Loop




End Sub