RESOLU - Excel VBA - Données, Dico, et MsgBox

G

Guillaume831

XLDnaute Nouveau
Bonjour à tous,

Je suis actuellement en train de travailler sur la construction d’un emploi du temps intelligent et multifonctionnel. En tant qu’étudiant, j’en profite du coup pour me former au VBA sur Excel.

Afin de mieux comprendre la situation, je vais décrire mon fichier. J’ai deux premiers onglets administratifs, qui comportent des paramètres bateaux pour excel, dont un tableauA, dont chaque ligne comprend le nom d’un prof, une heure de debut, de fin, et un cours. Ces informations sont ensuite répercutées dans l’onglet qui lui est destiné sous une autre forme. Ce tableauA est appelé à compter plusieurs lignes, et ce qui m’intéresse désormais maintenant, c’est de créer une macro qui me permettraient de connaître quel prof serait dispos avec les critères établis. Je vous laisse lire le code ci-dessous.

Mais mon code ne marche pas, et je désespère un peu là…

Je me suis permis de publier ce post sur plusieurs forums. Ne vous en sentez pas offusqués, c’est juste pour pouvoir étudier les différents réponses qui me seraient proposées.

Cordialement,

Guillaume

Fichier Sans Macro : Cijoint.fr - Service gratuit de dépôt de fichiers
Fichier XL2007 avec Macro : Cijoint.fr - Service gratuit de dépôt de fichiers
Fichier XL 97-2003 : Cijoint.fr - Service gratuit de dépôt de fichiers

Code: 
Option Explicit

Sub QuiEstDispo()

Dim ValeurRecherche, RangePlage
Dim Jour As String, Debut As String, Fin As String
Dim Colonne As Integer, RangeeD As Integer, RangeeF As Integer
Dim NomdeProf As Range

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

Set DicoProfs = CreateObject("Scripting.Dictionary")

Jour = InputBox("Ecrivez un jour : Lundi, Mardi, Mercredi, Jeudi, Vendredi, Samedi", "Quel jour vous intéresse?") 'définit le jour intéressant

Select Case Jour
    Case "Lundi": Colonne = 3
    Case "Mardi": Colonne = 4
    Case "Mercredi": Colonne = 5
    Case "Jeudi": Colonne = 6
    Case "Vendredi": Colonne = 7
    Case "Samedi": Colonne = 8
    Case Else
        MsgBox "Veuillez indiquer un jour de la semaine correct!"
        Exit Sub
End Select
    
Debut = InputBox("De quelle heure? - Format : XX:XX:XX ") 'définit le début de la plage horaire

Select Case Debut
    Case "08:00:00": RangeeD = 4
    Case "08:30:00": RangeeD = 5
    Case "09:00:00": RangeeD = 6
    Case "09:30:00": RangeeD = 7
    Case "10:00:00": RangeeD = 8
    Case "10:30:00": RangeeD = 9
    Case "11:00:00": RangeeD = 10
    Case "11:30:00": RangeeD = 11
    Case "12:00:00": RangeeD = 12
    Case "12:30:00": RangeeD = 13
    Case "13:00:00": RangeeD = 14
    Case "13:30:00": RangeeD = 15
    Case "14:00:00": RangeeD = 16
    Case "14:30:00": RangeeD = 17
    Case "15:00:00": RangeeD = 18
    Case "15:30:00": RangeeD = 19
    Case "16:00:00": RangeeD = 20
    Case "16:30:00": RangeeD = 21
    Case "17:00:00": RangeeD = 22
    Case "17:30:00": RangeeD = 23
    Case "18:00:00": RangeeD = 24
Case Else
        MsgBox "Veuillez indiquer un horaire correct! - Format : XX:XX:XX "
        Exit Sub
End Select
    
Fin = InputBox("Jusqu'à quelle heure? - Format : XX:XX:XX ") 'définit la fin de la plage horaire
Select Case Fin
    Case "08:00:00": RangeeF = 4
    Case "08:30:00": RangeeF = 5
    Case "09:00:00": RangeeF = 6
    Case "09:30:00": RangeeF = 7
    Case "10:00:00": RangeeF = 8
    Case "10:30:00": RangeeF = 9
    Case "11:00:00": RangeeF = 10
    Case "11:30:00": RangeeF = 11
    Case "12:00:00": RangeeF = 12
    Case "12:30:00": RangeeF = 13
    Case "13:00:00": RangeeF = 14
    Case "13:30:00": RangeeF = 15
    Case "14:00:00": RangeeF = 16
    Case "14:30:00": RangeeF = 17
    Case "15:00:00": RangeeF = 18
    Case "15:30:00": RangeeF = 19
    Case "16:00:00": RangeeF = 20
    Case "16:30:00": RangeeF = 21
    Case "17:00:00": RangeeF = 22
    Case "17:30:00": RangeeF = 23
    Case "18:00:00": RangeeF = 24
Case Else
        MsgBox "Veuillez indiquer un horaire correct! - Format : XX:XX:XX "
        Exit Sub
End Select

RangePlage = Range(Cells(RangeeD, Colonne), Cells(RangeeF, Colonne)).Address 'est censée représenter la plage horaire du jour défini pour l'analyse ci-dessous

' dans ce qui suit, je cherche à sélectionner les profs suivants ces critères:
'  - en respectant la rangeplage : plage horaire choisie, selon le jour qui convient
'  - en ignorant les cases qui sont coloriées. Elles signifient que le professeur s'est mis en indisponibilités à ce moment là.
'  - en ignorant les cases qui sont déjà pleines, car s'ils ont déjà un cours, ils ne sont pas dispos pour un nouveau cours!
'  - si les critères ci-dessus sont respectés, alors la macro enregistre le nom du prof, en E1 sur chaque onglet de prof, et me l'enregistre dans DicoProfs
'alors, ma MsgBox me donne au final la liste des profs répondant à tous les critères ci-dessus

For Each ValeurRecherche In Range(RangePlage)
    If Not DicoProfs.Exists(Cells(1, 5).Value) And
        With ValeurRecherche
        .Value = ""
        .Selection.Interior.Pattern = xlNone
        End With
    Then DicoProfs.Add Cells(1, 5).Value, Cells(1, 5).Value
    End If
Next ValeurRecherche

MsgBox (Application.Transpose(DicoProfs.Items))

End Sub
 
Dernière édition:
Trier par date Trier par votes
Efgé

Efgé

XLDnaute Barbatruc
Re : Excel VBA - Données, Dico, et MsgBox

Bonjour Guillaume831,
Quelques remarques, si j'ai bien compris la demande:
VB: 
Sub QuiEstDispo_2()
Dim DicoProfs As Object ' il faut déclarer le dictionnaire
Dim Tablo As Variant 'on aura besoin d'un tableau
Set DicoProfs = CreateObject("Scripting.Dictionary")
'************
'*   Ton code
'************
'Pour chaque Cellule dans la plage
For Each ValeurRecherche In Range(RangePlage)
    'On reprend le nom dans le dico
   DicoProfs(Cells(1, 5).Value) = Cells(1, 5).Value
Next ValeurRecherche
'On passe les items dans un tableau
Tablo = DicoProfs.Items
'On affiche le tableau dans une MsgBox
MsgBox Join(Tablo, vbLf)
'*********************************
'* Ou on peut coller les items sur une feuille:
'Sheets('"Feuil1").Range("A1").Resize(DicoProfs.Count, 1) = _
Application.Transpose(DicoProfs.Items)
'*********************************
'Ne pas oublier de réactiver l'affichage
Application.ScreenUpdating = True
End Sub
Cordialement
 
Dernière édition:
Vote positif 0 Vote négatif
F

flyonets44

XLDnaute Occasionnel
Re : Excel VBA - Données, Dico, et MsgBox

Bonjour Guillaume831
Il faut aussi penser à réactiver le mode automatique du calcul en fin de macro, sinon tu obtiens des résultats erronés !
Application.Calculation = xlCalculationAutomatic
End sub
 
Vote positif 0 Vote négatif
G

Guillaume831

XLDnaute Nouveau
Re : Excel VBA - Données, Dico, et MsgBox

Je vous remercie à tous les deux.
Toutefois, j'ai bien une MsgBox qui s'ouvre mais elle est vide.
Je ne sais pas si vous avez eu le temps de regarder mon fichier, mais si par exemple je demande le Lundi de 08:30:00 à 10:30:00 je devrai au moins avoir Jean, mais ce n'est pas le cas...
Aussi, pouvez vous me dire si j'ai bien codé les critères de cellules vides et non colorées?

Merci encore
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : Excel VBA - Données, Dico, et MsgBox

Re
Peut être comme ça (pour la fin). Ne pas oublié de déclarer Dim ValeurRecherche As Range

VB: 
Sub QuiEstDispo_3()
Dim ValeurRecherche As Range
'Pour chaque Cellule dans la plage
For Each ValeurRecherche In Range(RangePlage)
    'On reprend le nom de la cellule en colonne F dans le dico
    DicoProfs(ValeurRecherche.Offset(0, 3).Value) = _
    ValeurRecherche.Offset(0, 3).Value
Next ValeurRecherche
Tablo = DicoProfs.Items
MsgBox Join(Tablo, vbLf)
'Ne pas oublier de réactiver l'affichage et le calcul ;)
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub
Cordialement
 
Vote positif 0 Vote négatif
G

Guillaume831

XLDnaute Nouveau
Re : Excel VBA - Données, Dico, et MsgBox

Les gars, je vous remercie de votre temps... On vient de me filer ça sur un autre forum, je le partage avec vous! :)

BOnne analyse!


Code: 
Option Explicit



Sub QuiEstDispo()

Dim ValeurRecherche, RangePlage
Dim Jour As String, Debut As String, Fin As String
Dim Colonne As Integer, RangeeD As Integer, RangeeF As Integer
Dim NomdeProf As Range
Dim dicoprofs As Object
Dim curSheet As Worksheet
Dim curligne As Integer
Dim result() As String
Dim BreakBoucle As Boolean
Dim I As Integer
Dim reponse As String

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

Set dicoprofs = CreateObject("Scripting.Dictionary")

Jour = InputBox("Ecrivez un jour : Lundi, Mardi, Mercredi, Jeudi, Vendredi, Samedi", "Quel jour vous intéresse?") 'définit le jour intéressant

Select Case Jour
    Case "Lundi", "lundi": Colonne = 3
    Case "Mardi", "mardi": Colonne = 4
    Case "Mercredi", "mercredi": Colonne = 5
    Case "Jeudi", "jeudi": Colonne = 6
    Case "Vendredi", "vendredi": Colonne = 7
    Case "Samedi", "samedi": Colonne = 8
    Case Else
        MsgBox "Veuillez indiquer un jour de la semaine correct!"
        Exit Sub
End Select
    
Debut = InputBox("De quelle heure? - Format : XX:XX ") 'définit le début de la plage horaire

Select Case Debut
    Case "08:00": RangeeD = 4
    Case "08:30": RangeeD = 5
    Case "09:00": RangeeD = 6
    Case "09:30": RangeeD = 7
    Case "10:00": RangeeD = 8
    Case "10:30": RangeeD = 9
    Case "11:00": RangeeD = 10
    Case "11:30": RangeeD = 11
    Case "12:00": RangeeD = 12
    Case "12:30": RangeeD = 13
    Case "13:00": RangeeD = 14
    Case "13:30": RangeeD = 15
    Case "14:00": RangeeD = 16
    Case "14:30": RangeeD = 17
    Case "15:00": RangeeD = 18
    Case "15:30": RangeeD = 19
    Case "16:00": RangeeD = 20
    Case "16:30": RangeeD = 21
    Case "17:00": RangeeD = 22
    Case "17:30": RangeeD = 23
    Case "18:00": RangeeD = 24
Case Else
        MsgBox "Veuillez indiquer un horaire correct! - Format : XX:XX:XX "
        Exit Sub
End Select
    
Fin = InputBox("Jusqu'à quelle heure? - Format : XX:XX ") 'définit la fin de la plage horaire
Select Case Fin
    Case "08:00": RangeeF = 4
    Case "08:30": RangeeF = 5
    Case "09:00": RangeeF = 6
    Case "09:30": RangeeF = 7
    Case "10:00": RangeeF = 8
    Case "10:30": RangeeF = 9
    Case "11:00": RangeeF = 10
    Case "11:30": RangeeF = 11
    Case "12:00": RangeeF = 12
    Case "12:30": RangeeF = 13
    Case "13:00": RangeeF = 14
    Case "13:30": RangeeF = 15
    Case "14:00": RangeeF = 16
    Case "14:30": RangeeF = 17
    Case "15:00": RangeeF = 18
    Case "15:30": RangeeF = 19
    Case "16:00": RangeeF = 20
    Case "16:30": RangeeF = 21
    Case "17:00": RangeeF = 22
    Case "17:30": RangeeF = 23
    Case "18:00": RangeeF = 24
Case Else
        MsgBox "Veuillez indiquer un horaire correct! - Format : XX:XX:XX "
        Exit Sub
End Select

' RangePlage = Range(Cells(RangeeD, Colonne), Cells(RangeeF, Colonne)).Address 'est censée représenter la plage horaire du jour défini pour l'analyse ci-dessous

' dans ce qui suit, je cherche à sélectionner les profs suivants ces critères:
'  - en respectant la rangeplage : plage horaire choisie, selon le jour qui convient
'  - en ignorant les cases qui sont coloriées. Elles signifient que le professeur s'est mis en indisponibilités à ce moment là.
'  - en ignorant les cases qui sont déjà pleines, car s'ils ont déjà un cours, ils ne sont pas dispos pour un nouveau cours!
'  - si les critères ci-dessus sont respectés, alors la macro enregistre le nom du prof, en E1 sur chaque onglet de prof, et me l'enregistre dans DicoProfs
'alors, ma MsgBox me donne au final la liste des profs répondant à tous les critères ci-dessus
ReDim result(0)
result(0) = ""
For Each curSheet In Sheets
    If curSheet.Name <> "Administratif" And curSheet.Name <> "Cours" Then
        curSheet.Activate
        BreakBoucle = False
        For curligne = RangeeD To RangeeF
            If GetValue(translateCoord(curligne, Colonne)) = "" Then
                If Selection.Interior.Pattern <> xlNone Then
                    BreakBoucle = True
                    Exit For
                End If
            Else
                BreakBoucle = True
                Exit For
            End If
        Next curligne
        If Not BreakBoucle Then
            result(UBound(result)) = GetValue(translateCoord(1, 5))
            ReDim Preserve result(UBound(result) + 1)
        End If
    End If
Next
If UBound(result) > 0 Then ReDim Preserve result(UBound(result) - 1)
Sheets("Cours").Activate
If result(0) <> "" Then
    reponse = "liste des personnes dispo:"
    For I = 0 To UBound(result)
        reponse = reponse + vbCrLf + result(I)
    Next I
    MsgBox (reponse)
Else
    MsgBox "personne de dispo"
End If
End Sub

Private Function translateCoord(NumLine As Integer, NumCol As Integer) As String
    translateCoord = TranslateNumColIntoChar(NumCol) & Trim(Str(NumLine))
End Function
Private Function TranslateNumColIntoChar(NumCol As Integer) As String
Dim Reste As Long

    If NumCol <= 26 Then
        TranslateNumColIntoChar = Chr(Asc("A") + NumCol - 1)
    Else
        Reste = (NumCol - 1) Mod 26
        TranslateNumColIntoChar = Chr(Asc("A") + Int((NumCol - 1) / 26) - 1) & Chr(Asc("A") + Reste)
    End If
End Function
Private Function GetValue(cellule As String) As Variant
    Range(cellule).Select
    GetValue = ActiveCell.Value
End Function
 
Vote positif 0 Vote négatif

Discussions similaires

T
  • Résolu(e)
XL 2019 VBA - Comparaison d'heures
Réponses
9
Affichages
228
ThierryP
T
M
  • Question
XL pour MAC outil de gestion du temps de travail
Réponses
1
Affichages
590
gbinforme
G
X
  • Résolu(e)
XL 2016 occurrence par date et heure
Réponses
2
Affichages
294
xbooster
X
HE_RA
  • Question
XL 2019 Calculer la somme de plusieurs dates personnalisés (00A00M17J)
Réponses
10
Affichages
301
HE_RA
HE_RA
M
  • Résolu(e)
XL 2016 VBA - Traitement de données en fonction de plusieurs critères avec Dictionary
2
Réponses
29
Affichages
963
Mak_tarmak
M
M
  • Question
XL 2016 Impression d'un rapport PDF depuis une URL avec VBA
Réponses
3
Affichages
521
mrcooll
M
A
  • Question
XL 2016 Combobox Saisie Date
Réponses
12
Affichages
485
aurelio.ewane
A
D
  • Question
XL 2016 Problème de conversion sur VBA Excel
Réponses
1
Affichages
336
vgendron
vgendron
Y
  • Question
XL 2019 Afficher un texte avec conditions multiples
Réponses
1
Affichages
346
sylvanu
sylvanu
chaelie2015
  • Résolu(e)
XL 2013 (RESOLU) Couleur unique à chaque doublon différent
Réponses
11
Affichages
348
chaelie2015
chaelie2015

Membres actuellement en ligne

7 membres et 74 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
312 069
Messages
2 085 042
Membres
102 765
dernier inscrit
richdi