XL 2019 Problème de boucle ou de variables

L

Lucien31

XLDnaute Nouveau
Bonjour à Tous,
Je reviens vers vous car je bloque depuis plusieurs jours sur le fonctionnement d'une procédure. Je vais essayer d'expliquer ce que je rencontre mais j'ai du mal à identifier l'origine du problème.
Il s'agit d'un planning dans lequel on enregistre des personnes (noms), et des tâches à réaliser. J'ai prévu la possiblité de créer des "taches récurrentes" (des tâches qui se répètent par exemple tous les mardis et mercredi dans une période définie) et c'est là que l bas blesse: Sur les deux premiers noms, cela se passe bien mais quand j'en ai ajouté un troisième, "le contrôle de tâches existantes" que j'ai mis me renvoie systématiquement "qu'un tâche a déjà été assignée à cet intervenant". Et c'est là où j'espère votre aide.

Dans le fichier "2020" joint, la procédure à bien fonctionné sur "RESPONSABLE" et "ADJOINT" mais pas pour "EXEMPLE". J'ai fait les tests sur deux jours consécutifs à chaque fois.

Je vous joins les trois fichiers suivants:
-"Ouvrir Planning" qui comme son nom l'indique permet d'ouvrir
-"Menu" qui est alimentée par un userform pour finalement alimenter le tableau planning
-"2020" qui est est la feuille que voit l'utilisateur (en fait, il y en a plusieurs mais j'ai isolé la première pour simplifier). J'ai du le compresser.

Voici maintenant le code de la procédure "Tache récurrente" qui m'amène vers vous (c'est un peu long et je m'en excuse par avance):
(J'implore votre indulgence car je suis moins que débutant en codage VBA. Je n'ai fait qu'accoler des bouts de code pêcher par ci par là.)
<
Sub TacheReccurentes()

Dim Annee(5) As String
Dim a As Integer
Dim Classeur As Workbook
Dim Cel As Range
Dim Plage As Range
Dim Mg As String, TB
Dim Nom As String
Dim ApartirDu As Date
Dim DateFin As Date
Dim k As Integer
Dim f As Integer
Dim AnneeDeb As Integer
Dim AnneeFin As Integer
Dim debut As String
Dim fin As String





With ActiveWorksheet
Call MoisSaisi

'Gestion début des tâches commencées de nuit
Call HeuresNuit

' AnneeDeb = Workbooks("Menu.xlsm").Worksheets("Menu").Range("A6")
'AnneeFin = Workbooks("Menu.xlsm").Worksheets("Menu").Range("D39")

Range("B4").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("F7").Value
Range("C4").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("D17").Value
Range("C5").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("D40").Value
Range("D4").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("H7").Value
Range("F4").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("J7").Value

'Renvoi des jours cochés sur la feuille active
Range("I5").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("L8").Value
Range("J5").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("M8").Value
Range("K5").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("N8").Value
Range("L5").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("O8").Value
Range("M5").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("P8").Value
Range("N5").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("Q8").Value
Range("O5").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("R8").Value
Range("I6").Value = "lundi"
Range("J6").Value = "mardi"
Range("K6").Value = "mercredi"
Range("L6").Value = "jeudi"
Range("M6").Value = "vendredi"
Range("N6").Value = "samedi"
Range("O6").Value = "dimanche"


'B les Variables

ApartirDu = Range("C4")
DateFin = Range("C5")
Nom = Range("B4")
debut = Range("D4")
fin = Range("F4")
Tache = Range("H3")
cola = Rows(13).Find(fin).Column
colde = Rows(13).Find(debut).Column
k = Sheets.Count






For f = ActiveSheet.index To k
Sheets(f).Activate



For i = Range("C1000").End(xlUp).Row To 2 Step -1




For Each c In Range("I5:O5").Cells
If c.Value = 1 And Cells(i, 70).Value = c.Offset(1, 0) And Cells(i, 2).Value >= ApartirDu And Cells(i, 2).Value <= DateFin Then
Range("C6").Value = Cells(i, 2).Value
Lig = Evaluate("Match(1,(B1:B1000=C6)*(C1:C1000=B4),0)")
End If
Next c

Next i

'Boucle de contrôle de tâche existante
With Sheets

On Error Resume Next
Set Plage = Range(Cells(Lig, colde), Cells(Lig, cola))
If Err <> 0 Then
MsgBox ("Le nom choisi n'est pas créé à la date saisie pour la tâche." & Chr(10) & "Si l'intervenant devait arriver plus tard, vous devez le supprimer du programme (à partir du 01 jan 2020): fonction <Supprimer un Nom> et le re-créer à partir de la bonne date: fonction <Ajouter un Nom>" & Chr(10) & " Notez que les tâches déjà créees seront éffacées, il faudra donc les ressaisir." & Chr(10) & "S'il a préalablement été supprimé, il suffit de le re-créer à partir de la date prévue pour la tâche.")
On Error GoTo 0
On Error Resume Next
Set WB = Workbooks("2020.xlsm")
If Not WB Is Nothing Then WB.Close False
On Error GoTo 0

Call MoisActuel
Exit Sub
End If


For Each Cel In Plage
Mg = Cel.MergeArea.Address
TB = Split(Mg, ":")
If Range(TB(0)).Value <> "" Then
MsgBox ("Une tâche a déjà été assignée à cet intervenant sur cette période." & Chr(10) & "Cliquez sur OK pour vérifier et corriger le cas échéant" & Chr(10) & "Vous serez rammenés dans le mois courant")
Range(TB(0)).Select
On Error Resume Next
Set WB = Workbooks("2020.xlsm")
If Not WB Is Nothing Then WB.Close False
On Error GoTo 0

Call MoisActuel
Exit Sub
Else
Range(Mg).Locked = False
End If
Next Cel

End With
'fin de contrôle

'Mise en forme de la plage si tout est ok



Call Taches


'Vérrouillage de la plage
ActiveSheet.Unprotect
Range(Cells(Lig, colde), Cells(Lig, cola)).Select
Selection.Locked = True
ActiveSheet.Protect



Next f






'End If
End With




'G Confirmation ou annulation
Call MoisSaisi
Call Ligne_Heures
Lig = Evaluate("Match(1,(B1:B1000=C4)*(C1:C1000=B4),0)")
Range(Cells(Lig, colde), Cells(Lig, cola)).Select


If MsgBox("Vérifiez votre saisie et Cliquez sur OK pour Enregistrer définitivement la tâche sinon sur Annuler", vbOKCancel, "Demande de confirmation") = vbCancel Then 'Si le bouton Annuler est cliqué ...

'Application.ScreenUpdating = False


On Error Resume Next
Set WB = Workbooks("2020.xlsm")
If Not WB Is Nothing Then WB.Close False
On Error GoTo 0

Call MoisActuel
Exit Sub

'ferme et enregistre les modifications sur les années ouvertes et revient au mois en cours si on clique sur "OK"

Else
Application.ScreenUpdating = False


'Boite de dialogue pour faire patientez
Application.Cursor = xlWait 'affiche le sablier
Enregistrement.Show vbModeless 'affiche la waitbox mais continu le traitement
Enregistrement.Repaint 'raffraichit le contenu affiché sinon on a une boite blanche vide

'On ferme les années non modifiées
If AnneeDeb > 2020 Then
On Error Resume Next
Workbooks("2020.xlsm").Close Savechanges:=False
End If
On Error GoTo 0



'On enregistre les autres
On Error Resume Next
Workbooks("2020.xlsm").Close Savechanges:=True
On Error GoTo 0




End If

'Boite de dialogue pour faire patientez
Application.Cursor = xlWait 'affiche le sablier
Enregistrement.Show vbModeless 'affiche la waitbox mais continu le traitement
Enregistrement.Repaint 'raffraichit le contenu affiché sinon on a une boite blanche vide




'masque la waitbox
Enregistrement.Hide
Application.Cursor = xlDefault 'remet le curseur par défaut


MsgBox "Enregistrement terminé. Cliquez sur OK"




Call MoisActuel
Application.ScreenUpdating = True

End Sub>


Voilà j'espère avoir été suffisement clair et vous pourrez m'aider.

Merci Beaucoup par avance
 

Pièces jointes

  • Menu.xlsm
    295.6 KB · Affichages: 8
  • Ouvrir planning.xlsm
    14.1 KB · Affichages: 3
  • 2020.zip
    543.6 KB · Affichages: 3
Trier par date Trier par votes
L

Lucien31

XLDnaute Nouveau
Bonjour Kiki29,
Je ne suis pas certain d'avoir compris ton message. Je comprends que je n'ai pas utiliser la bonne prodcédure pour joindre le code. Désoslé mais je ne suis pas du tout habitué aux forum. J'esp^ère que fais bien cette fois pôur le code, mais y a-t-il autre chose ?

merci pour ton regard
Bonne soirée
VB: 
Sub TacheReccurentes()

Dim Annee(5) As String
Dim a As Integer
Dim Classeur As Workbook
Dim Cel As Range
Dim Plage As Range
Dim Mg As String, TB
Dim Nom As String
Dim ApartirDu As Date
Dim DateFin As Date
Dim k As Integer
Dim f As Integer
Dim AnneeDeb As Integer
Dim AnneeFin As Integer
Dim debut As String
Dim fin As String


  

    
With ActiveWorksheet
   Call MoisSaisi

'Gestion début des tâches commencées de nuit
    Call HeuresNuit

   ' AnneeDeb = Workbooks("Menu.xlsm").Worksheets("Menu").Range("A6")
    'AnneeFin = Workbooks("Menu.xlsm").Worksheets("Menu").Range("D39")
    
    Range("B4").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("F7").Value
    Range("C4").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("D17").Value
    Range("C5").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("D40").Value
    Range("D4").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("H7").Value
    Range("F4").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("J7").Value
    
    'Renvoi des jours cochés sur la feuille active
    Range("I5").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("L8").Value
    Range("J5").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("M8").Value
    Range("K5").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("N8").Value
    Range("L5").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("O8").Value
    Range("M5").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("P8").Value
    Range("N5").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("Q8").Value
    Range("O5").Value = Workbooks("Menu.xlsm").Worksheets("Menu").Range("R8").Value
    Range("I6").Value = "lundi"
    Range("J6").Value = "mardi"
    Range("K6").Value = "mercredi"
    Range("L6").Value = "jeudi"
    Range("M6").Value = "vendredi"
    Range("N6").Value = "samedi"
    Range("O6").Value = "dimanche"
  
    
'B les Variables

    ApartirDu = Range("C4")
    DateFin = Range("C5")
    Nom = Range("B4")
    debut = Range("D4")
    fin = Range("F4")
    Tache = Range("H3")
    cola = Rows(13).Find(fin).Column
    colde = Rows(13).Find(debut).Column
    k = Sheets.Count

      

 


For f = ActiveSheet.index To k
    Sheets(f).Activate
    
 
    
 For i = Range("C1000").End(xlUp).Row To 2 Step -1
 
 
 
 
 For Each c In Range("I5:O5").Cells
 If c.Value = 1 And Cells(i, 70).Value = c.Offset(1, 0) And Cells(i, 2).Value >= ApartirDu And Cells(i, 2).Value <= DateFin Then
 Range("C6").Value = Cells(i, 2).Value
 Lig = Evaluate("Match(1,(B1:B1000=C6)*(C1:C1000=B4),0)")
 End If
 Next c
 
 Next i

'Boucle de contrôle de tâche existante
 With Sheets
    
        On Error Resume Next
        Set Plage = Range(Cells(Lig, colde), Cells(Lig, cola))
        If Err <> 0 Then
        MsgBox ("Le nom choisi n'est pas créé à la date saisie pour la tâche." & Chr(10) & "Si l'intervenant devait arriver plus tard, vous devez le supprimer du programme (à partir du 01 jan 2020): fonction <Supprimer un Nom> et le re-créer à partir de la bonne date: fonction <Ajouter un Nom>" & Chr(10) & " Notez que les tâches déjà créees seront éffacées, il faudra donc les ressaisir." & Chr(10) & "S'il a préalablement été supprimé, il suffit de le re-créer à partir de la date prévue pour la tâche.")
        On Error GoTo 0
On Error Resume Next
Set WB = Workbooks("2020.xlsm")
If Not WB Is Nothing Then WB.Close False
On Error GoTo 0

Call MoisActuel
Exit Sub
        End If
        
              
       For Each Cel In Plage
            Mg = Cel.MergeArea.Address
            TB = Split(Mg, ":")
            If Range(TB(0)).Value <> "" Then
                MsgBox ("Une tâche a déjà été assignée à cet intervenant sur cette période." & Chr(10) & "Cliquez sur OK pour vérifier et corriger le cas échéant" & Chr(10) & "Vous serez rammenés dans le mois courant")
                Range(TB(0)).Select
On Error Resume Next
Set WB = Workbooks("2020.xlsm")
If Not WB Is Nothing Then WB.Close False
On Error GoTo 0

Call MoisActuel
Exit Sub
        Else
            Range(Mg).Locked = False
        End If
        Next Cel
      
  End With
'fin de contrôle
 
 'Mise en forme de la plage si tout est ok
 
 
 
 Call Taches
 

'Vérrouillage de la plage
 ActiveSheet.Unprotect
    Range(Cells(Lig, colde), Cells(Lig, cola)).Select
    Selection.Locked = True
    ActiveSheet.Protect
 


Next f



 

 
'End If
End With




'G Confirmation ou annulation
Call MoisSaisi
Call Ligne_Heures
Lig = Evaluate("Match(1,(B1:B1000=C4)*(C1:C1000=B4),0)")
Range(Cells(Lig, colde), Cells(Lig, cola)).Select


  If MsgBox("Vérifiez votre saisie et Cliquez sur OK pour Enregistrer définitivement la tâche sinon sur Annuler", vbOKCancel, "Demande de confirmation") = vbCancel Then 'Si le bouton Annuler est cliqué ...
    
'Application.ScreenUpdating = False


On Error Resume Next
Set WB = Workbooks("2020.xlsm")
If Not WB Is Nothing Then WB.Close False
On Error GoTo 0

Call MoisActuel
Exit Sub

'ferme et enregistre les modifications sur les années ouvertes et revient au mois en cours si on clique sur "OK"

Else
Application.ScreenUpdating = False


'Boite de dialogue pour faire patientez
Application.Cursor = xlWait   'affiche le sablier
Enregistrement.Show vbModeless   'affiche la waitbox mais continu le traitement
Enregistrement.Repaint                   'raffraichit le contenu affiché sinon on a une boite blanche vide

'On ferme les années non modifiées
If AnneeDeb > 2020 Then
On Error Resume Next
Workbooks("2020.xlsm").Close Savechanges:=False
End If
On Error GoTo 0



'On enregistre les autres
On Error Resume Next
Workbooks("2020.xlsm").Close Savechanges:=True
On Error GoTo 0




End If
    
    'Boite de dialogue pour faire patientez
Application.Cursor = xlWait   'affiche le sablier
Enregistrement.Show vbModeless   'affiche la waitbox mais continu le traitement
Enregistrement.Repaint                   'raffraichit le contenu affiché sinon on a une boite blanche vide
    
      
      
 
 'masque la waitbox
Enregistrement.Hide
Application.Cursor = xlDefault 'remet le curseur par défaut


MsgBox "Enregistrement terminé. Cliquez sur OK"




 Call MoisActuel
Application.ScreenUpdating = True

End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Question
Microsoft 365 aide VBA excel
Réponses
4
Affichages
302
Oneida
Oneida
C
  • Résolu(e)
Autres Copier des données vers une nouvelle feuille excel VBA
2
Réponses
25
Affichages
577
Carolinebd
C
A
  • Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
136
patricktoulon
patricktoulon
S
  • Résolu(e)
Microsoft 365 VBA Match: comment éviter l'erreur?
2
Réponses
29
Affichages
359
Dranreb
Dranreb
E
  • Question
Microsoft 365 Excel VBA
Réponses
5
Affichages
323
Excellearning
E
Nicolas JACQUIN
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
1 K
Nicolas JACQUIN
Nicolas JACQUIN
M
  • Question
XL 2013 MACRO VBA pour imprimer tous les bulletins d'un établissement scolaire
Réponses
4
Affichages
218
MBEPID
M
M
  • Question
Microsoft 365 Erreur sur mon Code VBA
Réponses
2
Affichages
349
Gégé-45550
Gégé-45550
L
  • Question
VBA : erreur sur boucle
Réponses
2
Affichages
278
Latias
L
Cédric06400
  • Résolu(e)
XL 2021 Revenir sur Excel
Réponses
6
Affichages
390
Franc58
F

Membres actuellement en ligne

1 membres et 34 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 087
Messages
2 116 083
Membres
112 654
dernier inscrit
SADIKA