Agenda - Agendamento repetido

Caros amigos!

Partindo de exemplos como o Calendário TarefasRSA, e orientações do mestre Avelino em ajuste de datas estou chegando a um material novo para agendamentos.
Só que estou com um pequeno problema. Ao programar vários dias no calendário com os seguintes parâmetros:
A partir da data 01/09/2015
[10] dias
[x] Dias Corridos
[x]Segunda a Sexta
[x]Dias úteis

Está fazendo a programação perfeita, acontece que quando chega no primeiro dia útil após sábado, domingo e feriado do 07/09, a programação dos 3 dias se repete todas no mesmo dia e logo em seguida volta a programação normal.  Vejam imagem do exemplo e em seguida o código:

[img][/img]

Código:

Private Sub Comando18_Click()
Dim dt As Date, x1, I, dddd
Dim DB As Database, rs As Recordset
Dim Contar As Integer
Dim DtAnt As Date

Set DB = CurrentDb()
Set rs = DB.OpenRecordset("tblSample") 'Abre tabela parcelas

dt = Me.AppointmentDate

If IsNull(Me.qtds) And IsNull(Me.qtda) And IsNull(Me.qtdm) And IsNull(Me.qtdd) Then
MsgBox "Selecione a Qdt de Repetição Desejada!": Exit Sub
End If
 DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
If IsNull([AppointmentDesc]) Or IsNull([AppointmentDate]) Then
MsgBox """Descrição"", ""Data"" Não Podem Ser Nulos!"""
Exit Sub
End If
If IsNull(Me.Who) Then Me.Who = "Quem"
If IsNull(Me.What) Then Me.What = "O que"
If IsNull(Me.strWhere) Then Me.strWhere = "Onde"
If IsNull(Me.AppointmentTime) Then Me.AppointmentTime = "00:00:00"

'----Cadastra REPETIÇÕES Diárias ----------------------------------------------------------------------------
If Not IsNull(Me.qtdd) Then
x1 = MsgBox("Deseja Cadastrar Esta Tarefa na Agenda com " & Me.qtdd & " Repetições Diárias Seguidas ?", 1)
  If x1 <> 1 Then
  Exit Sub
  End If

For I = 1 To (Me.qtdd - 1)

rs.AddNew
    
    rs("AppointmentDesc") = Me.AppointmentDesc
    rs("AppointmentDate") = Me.AppointmentDate
    rs("AppointmentTime") = Me.AppointmentTime
    rs("Who") = Me.Who
    rs("What") = Me.What
    rs("strWhere") = Me.strWhere
    rs("Alarm") = Me.Alarm
    rs("TimeRepet") = Me.TimeRepet
    rs("email") = Me.email
    rs("fone") = Me.fone
    rs("cod") = Me.cod
    rs("ProgD") = Me.qtdd
    rs("ProgS") = Me.qtds
    rs("ProgM") = Me.qtdm
    rs("ProgA") = Me.qtda
    rs("Dias") = Me.Dias
    rs("Sem") = Me.Sem
    rs("Pos") = Me.Pos
    rs("DiasDD") = Me.DD
    rs("Anexo1") = Me.Local1
    rs("Anexo2") = Me.Local2
    rs("Anexo3") = Me.Local3
    rs("Quadro") = Me.Quadro
    rs("Seq") = I
    
'OK -----Dias corridos dom a dom --------

    If Me.Dias = 1 And Me.DDuteis = 0 And Me.Semana = 3 Then
    
         dt = Me.AppointmentDate + I
         rs("AppointmentDate") = dt
        
'-----Dias corridos seg a sex--------
    
    ElseIf Me.Dias = 1 And Me.DDuteis = -1 And Me.Semana = 1 Then
        
         dt = Me.AppointmentDate + I
         dt = fncAjustaData(dt, False)
         rs("AppointmentDate") = dt
         dt = dt + I
        
'-----Dias corridos seg a sab--------
    
    ElseIf Me.Dias = 1 And Me.DDuteis = -1 And Me.Semana = 2 Then
    
         dt = Me.AppointmentDate + I
         dt = fncAjustaFimSemD(dt, False)
         rs("AppointmentDate") = dt
         dt = dt + I

    Next I
MsgBox "Agendado com Sucesso!"
'DoCmd.OpenForm "frmCalendar", acNormal
Forms![frmCalendar].Requery
End If

End Sub

Alguém pode dá uma luz?