Hi, I am trying to create a loop that run through each organization level and create the shape accordingly. Currently I only get it to create the first shape but it won't run through and create the rest of it. For example if I have 3 people on level 2 it create 1 shape and stop. Below is the code I have so far, any help will be much appreciated.
VBA Code:
Level = 2
Staff.Range("M3").Value = Level
Staff.Range("A2:H" & LastRow).AdvancedFilter xlFilterCopy, CriteriaRange:=Staff.Range("M2:M3"), CopyToRange:=Staff.Range("P2:W2"), Unique:=True
LastResultRow = Staff.Range("P99999").End(xlUp).Row
If LastResultRow < 3 Then GoTo NoResults
Staff.Range("X3:X" & LastResultRow).Formula = Staff.Range("X1").Formula
'Sort based on underlings
With Staff.Sort
.SortFields.Clear
.SortFields.Add Key:=Staff.Range("X3"), SortOn:=xlSortOnValues, Order:=xlDescending 'Sort Supervisor Underlings
.SortFields.Add Key:=Staff.Range("T3"), SortOn:=xlSortOnValues, Order:=xlDescending 'Sort Staff Underlings
.SetRange Staff.Range("P3:X" & LastResultRow)
.Apply
End With
LevelQty = LastResultRow - 2
If Level = 2 Then '2nd Level (fist sub-row)
LeftPos = CentPos - ((((ShapeSpacer) * (LevelQty - 1)) + ShapeWidth) / 2)
PrevQty = LevelQty 'Save Previous Level Qty
PrevLeft = LeftPos
Else 'Remaining rows 'Add additonal spacers
LeftPos = CentPos - (((((ShapeWidth / 3) + ShapeSpacer) * (LevelQty - 2)) + ShapeWidth) / 2)
If PrevQty >= LevelQty And PrevQty <> 0 Then LeftPos = PrevLeft
PrevQty = LevelQty 'Save Previous Level Qty
PrevLeft = LeftPos
End If
LevelNumb = 1
StaffID = Staff.Range("P" & LevelNumb + 2).Value
StaffNm = Staff.Range("Q" & LevelNumb + 2).Value
Supervisor = Staff.Range("R" & LevelNumb + 2).Value
Position = Staff.Range("S" & LevelNumb + 2).Value
PicName = Staff.Range("V" & LevelNumb + 2).Value
PicFile = PicFolder & "\" & PicName 'Full Picture File
If Dir(PicFile, vbDirectory) = "" Then
PicFile = DefaultPic
If Dir(PicFile, vbDirectory) = "" Then PicFile = ""
End If
If LevelNumb <> 1 And Staff.Range("R" & LevelNumb + 2).Value <> Staff.Range("R" & LevelNumb + 1).Value Then 'Supervisor Change
LeftPos = LeftPos + 20
End If
'Locate Supervisor Of staff
Set FoundStaffRng = Staff.Range("Staff_Name").Find(Supervisor, , xlValues, xlWhole)
.Shapes("SampleGrp" & Style).Duplicate.Name = "ChartItem" & StaffID
With .Shapes("ChartItem" & StaffID)
.Top = TopPos
.Left = LeftPos
.GroupItems("StaffDesc").TextFrame2.TextRange.Text = StaffNm & vbCrLf & Position
If PicFile <> "" Then .GroupItems("StaffPic").Fill.UserPicture PicFile 'Set STaff Picture
LeftPos = LeftPos + ShapeSpacer
End With
If Not FoundStaffRng Is Nothing Then 'Found Supevrvisor
SupID = Staff.Range("A" & FoundStaffRng.Row).Value 'Supervisor ID
'Add Connector
.Shapes("SampleConn" & Style).Duplicate.Name = "ChartItem" & SupID & "_" & StaffID
'Connect Profile shapes
With .Shapes("ChartItem" & SupID & "_" & StaffID).ConnectorFormat
.BeginConnect OrgChart.Shapes("ChartItem" & SupID).GroupItems("StaffDesc"), 3
.EndConnect OrgChart.Shapes("ChartItem" & StaffID).GroupItems("StaffPic"), 1
End With
End If
Set FoundStaffRng = Nothing
