Problem med Array i VBA

Min Array skriver bara ut den första och den sista posten.
Här är koden
Det är den fetmarkerade texten jag tror problemet ligger i

Dim strPersonalCheck() As String
    
    strPersonalCheck = SetPersonalID
    con2 = True
    row2 = 2
    Do While con2 = True
        value = Sheets(eventSheet2).Cells(row2, 1).value
        If value <> "" Then
            number2 = row2
            title2 = Sheets(eventSheet2).Cells(number2, 1).value
            startDate2 = DateValue(Sheets(eventSheet2).Cells(number2, 2).value)
            endDate2 = DateValue(Sheets(eventSheet2).Cells(number2, 3).value)
            persons2 = Sheets(eventSheet2).Cells(number2, 4).value
            
[B]            strPersonal = Trim(persons2)
            arrpersonal = Split(strPersonal, ",", -1, 1)
            For Each strTemp In arrpersonal
            strEnPersonal = strTemp
           
     
            Do While startDate2 <= endDate2
              DueDate2 = Format(startDate2, "yyyy-mm-dd")
              personalPos = Application.Match(strEnPersonal, strPersonalCheck, False)
              asd2 = insertInfo2(DueDate2, personalPos, title2)
              startDate2 = DateAdd("d", 1, startDate2)
            Loop
             Next[/B]
        Else
            con2 = False
        End If
        
        row2 = row2 + 1
    Loop
End Sub
 Function SetPersonalID() As String()
    Dim con2 As Boolean
    con2 = True
    
    Dim number2 As Integer
    number2 = 1
    Dim value2 As String
    Dim personalID() As String
    
    Do While con2 = True
        value2 = Sheets(PersonalScheduleSheet).Cells(1, number2 + 1).value
        
        If value2 <> "" Then
            ReDim Preserve personalID(number2) As String
         
            personalID(number2 - 1) = value2
        Else
            con2 = False
        End If
        number2 = number2 + 1
    Loop
    
    SetPersonalID = personalID
End Function

Function insertInfo2(eventDate2, personalPos, title2)
    Dim row2 As Integer
    Dim con2 As Boolean
    con2 = True
    
    row2 = 2
    
    Do While con2 = True
        
        value2 = CStr(Sheets(PersonalScheduleSheet).Cells(row2, 1).value)
        If eventDate2 = value2 Then
            con2 = False
            Sheets(PersonalScheduleSheet).Cells(row2, personalPos + 1) = title2
        ElseIf value2 = "" Then
            con2 = False
        End If
        row2 = row2 + 1
    Loop
 insertInfo2 = ""
End Function

Någon som ser vad jag gör för fel?