Discussion :

[mmu68]

bonjour

j'ai des resa par chambre /par client / date arr / date depart dans excel et j'aimerais que des plages se colorent dans un planning pour les resa...Book1.xlsm
ca parait simple pour un expert, mais je ne suis qu'un novice...

je joins l'excel tempplate pour clarifier... j'aimerai que mes bandes jaunes s'affichent automatiquement avec le nom du client

Merci

[Tylert]

bonjour

j'ai des resa par chambre /par client / date arr / date depart dans excel et j'aimerais que des plages se colorent dans un planning pour les resa...
ca parait simple pour un expert, mais je ne suis qu'un novice...

Merci

Je te réponds avec les éléments que tu nous as donné :
Si tu as un planning, tu dois savoir quelle période de temps couvre une cellule excel.
Du coup, il faut parcourir tes résa, et déterminer quelles cellules de ton planning tu dois colorier en fonction de la résa et colorier les cellules correspondantes.

Bonne chance.

Après tu peux donner plus d'éléments et tu trouveras peut etre une bonne ame pour tout faire

[mmu68]

Je te réponds avec les éléments que tu nous as donné :
Si tu as un planning, tu dois savoir quelle période de temps couvre une cellule excel.
Du coup, il faut parcourir tes résa, et déterminer quelles cellules de ton planning tu dois colorier en fonction de la résa et colorier les cellules correspondantes.

Bonne chance.

Après tu peux donner plus d'éléments et tu trouveras peut etre une bonne ame pour tout faire

[Tylert]

J'ai codé un truc vite fait avec les hypothèse suivante:
j'ai mis le planning dans la 2ème feuille qui commence en colonne A pour les apparts, puis à partir de B pour les dates.
les lignes d'apparts sont les lignes 2, 3 et 4 (et ainsi de suite si tu es un super rentier et que tu as plus d'appart)

A noter que le code ci dessous ne marchera pas si tu changes l'ordre des feuilles (sauf à utiliser des references par nom plutôt que position) et aussi que l'algo colorie tout sans prendre en compte ce qui existait déjà. du coup il faut tout effacer si tu changes des dates dans ton tableau de résa car ca n'efface pas automatiqquement les vieilles résa que tu aurais modifiées ou supprimées.

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
 
Sub ColoriageResa()
 
Dim IndLigneResa As Integer
Dim IndLigneAppart As Integer
Dim IndJourDébut As Integer
Dim Sortie As Boolean
 
IndLigneResa = 3
Sortie = False
'Tant qu'il reste des lignes de resa à traiter
While ThisWorkbook.Worksheets(1).Range("A" & IndLigneResa).Value <> "" And Not Sortie
 
    'On se place sur le 1er jour du planning
    IndJourDébut = 2
 
    'On cherche la colonne correspondant au jour de début de la résa
    While ThisWorkbook.Worksheets(2).Cells(1, IndJourDébut).Value <> ThisWorkbook.Worksheets(1).Range("B" & IndLigneResa).Value And ThisWorkbook.Worksheets(2).Cells(1, IndJourDébut).Value <> ""
        IndJourDébut = IndJourDébut + 1
    Wend
 
    'si on a pas trouvé le jour de la résa, y'a un problème, on sort
    If ThisWorkbook.Worksheets(2).Cells(1, IndJourDébut).Value = "" Then
 
        MsgBox ("Erreur Date résa" & " B" & IndLigneResa)
        Sortie = True
 
    'si on a trouvé, il faut colorier et mettre le nom dans les bonnes cases
    Else
 
        'On recherche d'abord la ligne à colorier correspondant à l'appart de la resa
        IndLigneAppart = 2
        While ThisWorkbook.Worksheets(2).Cells(IndLigneAppart, 1).Value <> ThisWorkbook.Worksheets(1).Range("A" & IndLigneResa).Value And ThisWorkbook.Worksheets(2).Cells(IndLigneAppart, 1).Value <> ""
            IndLigneAppart = IndLigneAppart + 1
        Wend
 
        ' si on ne l'a pas trouvée: erreur
        If ThisWorkbook.Worksheets(2).Cells(IndLigneAppart, 1).Value = "" Then
            MsgBox ("Erreur Appart résa" & " A" & IndLigneResa)
            Sortie = True
        End If
 
        If Not Sortie Then
            'on inscrit le nom du mec qui a reservé
            ThisWorkbook.Worksheets(2).Cells(IndLigneAppart, IndJourDébut).Value = ThisWorkbook.Worksheets(1).Range("D" & IndLigneResa).Value
 
            'on cherche ensuite la date de fin de séjour tout en coloriant à chaque fois la case
            While ThisWorkbook.Worksheets(2).Cells(1, IndJourDébut).Value <= ThisWorkbook.Worksheets(1).Range("C" & IndLigneResa).Value And ThisWorkbook.Worksheets(2).Cells(1, IndJourDébut).Value <> ""
                ThisWorkbook.Worksheets(2).Cells(IndLigneAppart, IndJourDébut).Interior.Color = RGB(0, 0, 255)
                IndJourDébut = IndJourDébut + 1
            Wend
 
            'si on est à la fin mais qu'on est pas sorti du planning, c'est qu'on a pas trouvé la date de fin => erreur.
            If ThisWorkbook.Worksheets(2).Cells(1, IndJourDébut - 1).Value <> ThisWorkbook.Worksheets(1).Range("C" & IndLigneResa).Value Then
                MsgBox ("Erreur Date résa" & " C" & IndLigneResa)
                Sortie = True
            End If
 
        End If
    End If
 
    'on passe à la resa suivante
    IndLigneResa = IndLigneResa + 1
Wend
 
End Sub

le fichier excel mis à jour en pièce jointe.

[mmu68]

Génial merci, il faudrait juste que la couleur s'arrête un jour avant la date de départ...

[Tylert]

Essaye de répondre dans le corps du texte.
Sinon pour que la couleur s'arrette 1 jour avant, il faut que tu modifie le code de la facon suivante:

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
 
Sub ColoriageResa()
 
Dim IndLigneResa As Integer
Dim IndLigneAppart As Integer
Dim IndJourDébut As Integer
Dim Sortie As Boolean
 
IndLigneResa = 3
Sortie = False
'Tant qu'il reste des lignes de resa à traiter
While ThisWorkbook.Worksheets(1).Range("A" & IndLigneResa).Value <> "" And Not Sortie
 
    'On se place sur le 1er jour du planning
    IndJourDébut = 2
 
    'On cherche la colonne correspondant au jour de début de la résa
    While ThisWorkbook.Worksheets(2).Cells(1, IndJourDébut).Value <> ThisWorkbook.Worksheets(1).Range("B" & IndLigneResa).Value And ThisWorkbook.Worksheets(2).Cells(1, IndJourDébut).Value <> ""
        IndJourDébut = IndJourDébut + 1
    Wend
 
    'si on a pas trouvé le jour de la résa, y'a un problème, on sort
    If ThisWorkbook.Worksheets(2).Cells(1, IndJourDébut).Value = "" Then
 
        MsgBox ("Erreur Date résa" & " B" & IndLigneResa)
        Sortie = True
 
    'si on a trouvé, il faut colorier et mettre le nom dans les bonnes cases
    Else
 
        'On recherche d'abord la ligne à colorier correspondant à l'appart de la resa
        IndLigneAppart = 2
        While ThisWorkbook.Worksheets(2).Cells(IndLigneAppart, 1).Value <> ThisWorkbook.Worksheets(1).Range("A" & IndLigneResa).Value And ThisWorkbook.Worksheets(2).Cells(IndLigneAppart, 1).Value <> ""
            IndLigneAppart = IndLigneAppart + 1
        Wend
 
        ' si on ne l'a pas trouvée: erreur
        If ThisWorkbook.Worksheets(2).Cells(IndLigneAppart, 1).Value = "" Then
            MsgBox ("Erreur Appart résa" & " A" & IndLigneResa)
            Sortie = True
        End If
 
        If Not Sortie Then
            'on inscrit le nom du mec qui a reservé
            ThisWorkbook.Worksheets(2).Cells(IndLigneAppart, IndJourDébut).Value = ThisWorkbook.Worksheets(1).Range("D" & IndLigneResa).Value
 
            'on cherche ensuite la date de fin de séjour tout en coloriant à chaque fois la case
            While ThisWorkbook.Worksheets(2).Cells(1, IndJourDébut).Value < ThisWorkbook.Worksheets(1).Range("C" & IndLigneResa).Value And ThisWorkbook.Worksheets(2).Cells(1, IndJourDébut).Value <> ""
                ThisWorkbook.Worksheets(2).Cells(IndLigneAppart, IndJourDébut).Interior.Color = RGB(0, 0, 255)
                IndJourDébut = IndJourDébut + 1
            Wend
 
            'si on est à la fin mais qu'on est pas sorti du planning, c'est qu'on a pas trouvé la date de fin => erreur.
            If ThisWorkbook.Worksheets(2).Cells(1, IndJourDébut).Value <> ThisWorkbook.Worksheets(1).Range("C" & IndLigneResa).Value Then
                MsgBox ("Erreur Date résa" & " C" & IndLigneResa)
                Sortie = True
            End If
 
        End If
    End If
 
    'on passe à la resa suivante
    IndLigneResa = IndLigneResa + 1
Wend
 
End Sub

J'ai modifié la condition de sortie de la boucle de recherche de date de fin de < ou = en < tout cours. comme ca on s'arrette dès qu'on trouve la date de fin.
J'ai aussi modifié la condition de determination d'erreur sur cette recherche.