Discussion :

[frunch]

Bonjour à tous,
J'ai apprivoisé les dictionnaires et j'aimerais empêcher les doublons lorsque les opérations ne se font pas par macro. Je m'explique :
J'ai fait des tirages au sort sur les matières des emplois du temps d'une école sur une 15éne de classes.
La moitié environ des tirages se font, et le reste doit être fait au cas par cas, par macro pour continuer de gérer les doublons par dico.
Donc j'aimerais empêcher les suppressions avec la touche suppr, le déplacement ou la saisie.
J'ai mis un message d'avertissement dans le worksheet change (onglet ETelev), mais çà n'empêche rien.
Comme çà me semble difficile de le mettre en place, je vais mettre un bouton supprimer en attendant.
Voilà comment la macro du cas par cas fonctionne:
Un double clic dans une cellule d'emploi du temps dispo pour sélectionner la destination, F3 pour l'exemple d'un doublon. Un clic dans la zone des colonnes de H à M, à la ligne 8 pour le même exemple.
(J'ai déjà l'évènement selection change que je souhaite garder pour générer la couleur d'une classe cliquée.)
On ouvre le formulaire en clic droit et on clique sur la touche verte du "déplacement ET".

[frunch]

Bonjour,
En ajoutant une heure disponible à l'emploi du temps, je n'arrive pas:
- A enlever la disponibilité prise aux dico1 et 2 (clé1 = classe + créneau horaire onglet TC, clé2 = prof + créneau horaire)
- A ajouter les clés au dico des affectés 3 et 4.
Mes clés n'existent pas dans les dicos, alors qu'elles s'y affichent (col E et G onglet inv.)
Je pense que je dois recréer les dicos avec les plages générées dans l'onglet Inv
exemple avec l'horaire disponible pour le 1er prof à affecter (voir col M de ETElev) : Courvoisier pour la 6éme heure (derniere heure du lundi):
les clés sont: clé1: 6éme1-6 et clé2: Courvoisier-6

'4-ajout heure emploi du temps prof et matiere

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
Private Sub AjtEmpTps_click()
    Dim a%, b%, i%, j%, k%, m%, x%, cp1%, cp2%, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, dico1, dico2, dico3, dico4, cle1$, cle2$
    Application.ScreenUpdating = False
    Set ws2 = Sheets("ETelev")
    Set ws3 = Sheets("TC")
    Set ws4 = Sheets("ETecol")
    Set dico1 = CreateObject("scripting.dictionary") 'dispos apres TAS classes
    dico1.CompareMode = TextCompare
    Set dico2 = CreateObject("scripting.dictionary") 'dispos apres TAS profs
    dico2.CompareMode = TextCompare
    Set dico3 = CreateObject("scripting.dictionary") 'affectés classes
    dico3.CompareMode = TextCompare
    Set dico4 = CreateObject("scripting.dictionary") 'affectés profs
    dico4.CompareMode = TextCompare
    drn = ws2.Range("H2").End(xlDown).Row
    Sheets("ETelev").Activate
     k = ActiveCell.Row 'clic droit sur cellule départ
     x = dico3.Count
        For i = 3 To 168
            For j = 2 To 6
                'creation cles
                If ws2.Cells(i, j).Value = "X" Then
                    cle1 = ws2.Cells(k, 10).Value & "-" & ws3.Cells(i, j).Value  'classe
                    cle2 = ws2.Cells(k, 9).Value & "-" & ws3.Cells(i, j).Value 'prof
                    a = i: b = j 'stocker dans une autre variable
                    cp1 = cp1 + 1
                    Exit For
                End If
            Next j
        Next i
   ' MsgBox cle1 & " " & cle2: GoTo fin
             'si dispo classe en dico1 (apres TAS) et dispo prof en dico2, oter de dico1 et dico2, et ajout en affectés dico3 et 4
             If dico1.exists(cle1) And dico2.exists(cle2) Then 'col E et col G
                 dico1.Remove cle1
                 dico2.Remove cle2
                 dico3.Add cle1, "" 'col I
                 dico4.Add cle2, "" 'col K
             End If
             If dico3.Count = x + 1 Then
                For i = 3 To 168
                    For j = 2 To 6
                         ws2.Cells(a, b).Value = ws2.Cells(k, 8).Value  'matiere dans ET eleve
                         ws4.Cells(a, b).Value = ws2.Cells(k, 9).Value 'prof dans ET ecole
                         cp2 = cp2 + 1
                         Exit For
                    Next j
                Next i
             End If
        If cp1 = 0 Then
            MsgBox "Aucune X n'a été trouvée."
            GoTo fin
        ElseIf cp2 = 0 Then
            MsgBox "L'horaire n'est pas disponible dans l'emploi du temps du professeur."
            Cells(a, b).Value = ""
            GoTo fin
        End If
'affichage dicos
      Sheets("inv").Range("E2").Resize(dico1.Count) = Application.Transpose(dico1.Keys) 'dispos  apres TAS classes MAJ
      Sheets("inv").Range("G2").Resize(dico2.Count) = Application.Transpose(dico2.Keys) 'dispo profs  apres TAS MAJ
      Sheets("inv").Range("I2").Resize(dico3.Count) = Application.Transpose(dico3.Keys) 'affectés classes MAJ
      Sheets("inv").Range("K2").Resize(dico4.Count) = Application.Transpose(dico4.Keys) 'affectés profs MAJ
 '   End If
'fin
fin:
    Unload Me
    cpt2 = 4
    Application.ScreenUpdating = True
End Sub

forum.xlsm