XL 2016 MFC sur plage horaire à partir d'une autre feuille

[djvinceathome]

Bonjour,

J'ai un fichier Excel où j'ai plusieurs feuilles, dans la feuille besoin, j'encode différents planning par rapport à des lieux. J'aimerais que en fonction des différents lieux, les plages horaires correspondantes se mettent dans la feuille avant celle des besoins. Si pouvez m'aider ce serait bien
le fichier est en annexe

 

[GALOUGALOU]

Bonsoir djvinceathome bonsoir le forum
je ne suis pas sur d'avoir tout compris, mais je vous propose une solution par macro
Pour la feuille planning de chaque jour, la macro récupère les informations dans la feuille précédente. (valeurs, couleur cellule, couleur police).
Pour la compréhension deux onglets sont associés que j'appellerais "départ et arrivé".
Il est important de respecter l'ordonnance des onglets et de les garder associé dans tout le classeur, de colorer les cellules de l'onglet "départ" (texte et ou cellule).
Dans l'onglet "arrivé", les informations (de la colonne 3 de l'onglet départ) sont affichées et colorées. Par colonne toutes les cellules de valeurs identique sont fusionnées.
Dans chaque onglet "arrivé" placer un bouton pour déclencher la macro "ventilation".(ci-dessous)
Je vous ai mis au point les premières feuilles, il vous reste à configurer le classeur.
La macro principale qui gère l'ensemble du classeur.

Sub ventilation()
Dim F11 As Integer, F1 As Integer, F2 As Integer, i As Long, COL As Integer, couleur As Variant

Range("B4:AH100").Clear

ActiveWindow.FreezePanes = False
Application.ScreenUpdating = False
Application.EnableEvents = False
 Application.DisplayAlerts = False
 
F11 = Sheets(1).index
F1 = ActiveSheet.index
If F1 > F11 Then ' test sur f1 et f11
F2 = F1 - 1 'si vrai retrancher 1 à la valeur de f1 exemple si la feuille f1 est en quatrième position alors f2 sera celle en troisième position
End If



 li = Sheets(F1).Cells(36000, 1).End(xlUp).Row
ligne = Sheets(F2).Cells(36000, 2).End(xlUp).Row

For COL = 2 To 35
For i = 4 To li
For i2 = 4 To ligne
If Sheets(F1).Cells(3, COL) = Sheets(F2).Cells(i2, 4) Then 'test sur l'activité
If Sheets(F1).Cells(i, 1) < Sheets(F2).Cells(i2, 6) Then 'test sur l'heure de fin
If Sheets(F1).Cells(i, 1) >= Sheets(F2).Cells(i2, 5) Then 'test sur l'heure de début

Sheets(F1).Cells(i, COL) = Sheets(F2).Cells(i2, 3)  'renvoie la colonne 3
Sheets(F1).Cells(i, COL).Interior.Color = Sheets(F2).Cells(i2, 3).Interior.Color 'récupère la couleur cellule
Sheets(F1).Cells(i, COL).Font.Color = Sheets(F2).Cells(i2, 3).Font.Color   'récupère la couleur police
If Sheets(F1).Cells(i, COL) = Sheets(F1).Cells(i - 1, COL) Then Sheets(F1).Range(Cells(i, COL), Cells(i - 1, COL)).Merge 'fusionne avec la cellule précédente
If Sheets(F1).Cells(i, COL) = Sheets(F1).Cells(i - 2, COL) Then Sheets(F1).Range(Cells(i, COL), Cells(i - 2, COL)).Merge  ' si plage cellule fusionne toute la plage
End If
End If
End If
Next
Next
Next
Call bordure
Call centre
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
    Range("A4").Select
    ActiveWindow.FreezePanes = True
End Sub

cordialement
galougalou

 

[djvinceathome]

Bonsoir djvinceathome bonsoir le forum
je ne suis pas sur d'avoir tout compris, mais je vous propose une solution par macro
Pour la feuille planning de chaque jour, la macro récupère les informations dans la feuille précédente. (valeurs, couleur cellule, couleur police).
Pour la compréhension deux onglets sont associés que j'appellerais "départ et arrivé".
Il est important de respecter l'ordonnance des onglets et de les garder associé dans tout le classeur, de colorer les cellules de l'onglet "départ" (texte et ou cellule).
Dans l'onglet "arrivé", les informations (de la colonne 3 de l'onglet départ) sont affichées et colorées. Par colonne toutes les cellules de valeurs identique sont fusionnées.
Dans chaque onglet "arrivé" placer un bouton pour déclencher la macro "ventilation".(ci-dessous)
Je vous ai mis au point les premières feuilles, il vous reste à configurer le classeur.
La macro principale qui gère l'ensemble du classeur.

Sub ventilation()
Dim F11 As Integer, F1 As Integer, F2 As Integer, i As Long, COL As Integer, couleur As Variant

Range("B4:AH100").Clear

ActiveWindow.FreezePanes = False
Application.ScreenUpdating = False
Application.EnableEvents = False
 Application.DisplayAlerts = False
 
F11 = Sheets(1).index
F1 = ActiveSheet.index
If F1 > F11 Then
F2 = F1 - 1
End If



 li = Sheets(F1).Cells(36000, 1).End(xlUp).Row
ligne = Sheets(F2).Cells(36000, 2).End(xlUp).Row

For COL = 2 To 35
For i = 4 To li
For i2 = 4 To ligne
If Sheets(F1).Cells(3, COL) = Sheets(F2).Cells(i2, 4) Then 'test sur l'activité
If Sheets(F1).Cells(i, 1) < Sheets(F2).Cells(i2, 6) Then 'test sur l'heure de fin
If Sheets(F1).Cells(i, 1) >= Sheets(F2).Cells(i2, 5) Then 'test sur l'heure de début

Sheets(F1).Cells(i, COL) = Sheets(F2).Cells(i2, 3)  'renvoie la colonne 3
Sheets(F1).Cells(i, COL).Interior.Color = Sheets(F2).Cells(i2, 3).Interior.Color 'récupère la couleur cellule
Sheets(F1).Cells(i, COL).Font.Color = Sheets(F2).Cells(i2, 3).Font.Color   'récupère la couleur police
If Sheets(F1).Cells(i, COL) = Sheets(F1).Cells(i - 1, COL) Then Sheets(F1).Range(Cells(i, COL), Cells(i - 1, COL)).Merge 'fusionne avec la cellule précédente
If Sheets(F1).Cells(i, COL) = Sheets(F1).Cells(i - 2, COL) Then Sheets(F1).Range(Cells(i, COL), Cells(i - 2, COL)).Merge  ' si plage cellule fusionne toute la plage
End If
End If
End If
Next
Next
Next
Call bordure
Call centre
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
    Range("A4").Select
    ActiveWindow.FreezePanes = True
End Sub

cordialement
galougalou

Un grand merci, c'est exactement ce que je voulais, comment avez vous fait pour faire cela, combien de macro y a t il ?

 

[GALOUGALOU]

re djvinceathome
une macro principale, ci-dessous et deux macros secondaires, mais qui auraient pu figurer dans le 1er
Je vous ai détaillé, pas à pas, les actions de la macro.
Quand vous la déclenchez, celle-ci identifie la feuille active et sa voisine précédente en stockant la position dans des variables.
Je vous laisse découvrir le principe de fonctionnement

Sub ventilation()
Dim F11 As Integer, F1 As Integer, F2 As Integer, i As Long, COL As Integer, couleur As Variant

Range("B4:AH100").Clear  'efface toute la plage, valeur,mise en forme, bordure,cellules fusionnées

ActiveWindow.FreezePanes = False 'desactive les cellules figées, ligne de 1 à 4
Application.ScreenUpdating = False 'desactive la mise à jour écran
Application.EnableEvents = False 'desactivé pour éviter le risque d'avoir une boucle sans fin d'action et de réaction.
 Application.DisplayAlerts = False 'desactive les alertes windows, par exemple lors d'une fusion de deux cellules avec valeurs
 
F11 = Sheets(1).index   'stocke dans la variable F11 la position de la 1re feuille du classeur
F1 = ActiveSheet.index 'stocke dans la variable F1 la position de la feuille active
If F1 > F11 Then  ' si f1 est plus grand que f11 alors
F2 = F1 - 1  'stocke la position de la feuille précédente de F1
End If


 li = Sheets(F1).Cells(36000, 1).End(xlUp).Row  ' dernière ligne avec valeurs de la 1re colonne de la feuille F1
ligne = Sheets(F2).Cells(36000, 2).End(xlUp).Row ' dernière ligne avec valeurs de la 2ᵉ colonne de la feuille F2

For COL = 2 To 35   'boucle sur colonne de 2 à 35 pour la feuille F1
For i = 4 To li   'boucle sur ligne de 4 à la fin pour la feuille F1
For i2 = 4 To ligne 'boucle sur ligne de 4 à la fin pour la feuille F2
If Sheets(F1).Cells(3, COL) = Sheets(F2).Cells(i2, 4) Then 'test sur l'activité
If Sheets(F1).Cells(i, 1) < Sheets(F2).Cells(i2, 6) Then 'test sur l'heure de fin
If Sheets(F1).Cells(i, 1) >= Sheets(F2).Cells(i2, 5) Then 'test sur l'heure de début

Sheets(F1).Cells(i, COL) = Sheets(F2).Cells(i2, 3)  'renvoie la colonne 3
Sheets(F1).Cells(i, COL).Interior.Color = Sheets(F2).Cells(i2, 3).Interior.Color 'récupère la couleur cellule
Sheets(F1).Cells(i, COL).Font.Color = Sheets(F2).Cells(i2, 3).Font.Color   'récupère la couleur police
If Sheets(F1).Cells(i, COL) = Sheets(F1).Cells(i - 1, COL) Then Sheets(F1).Range(Cells(i, COL), Cells(i - 1, COL)).Merge 'fusionne avec la cellule précédente
If Sheets(F1).Cells(i, COL) = Sheets(F1).Cells(i - 2, COL) Then Sheets(F1).Range(Cells(i, COL), Cells(i - 2, COL)).Merge  ' si plage cellule fusionne toute la plage
End If
End If
End If
Next
Next
Next
Call bordure 'exécute la macro bordure, bordure autour des cellules de la plage obligatoire, car l'instruction .clear en début de macro à effacée toutes les lignes
Call centre  'exécute la macro centre, écriture au centre de la cellule, nécessaire, car l'instruction .clear en début de macro à annuler cette disposition
Application.ScreenUpdating = True 'active la mise à jour de l'écran
Application.EnableEvents = True  'active les événements comme l'activation d'une feuille, une procédure double clic etc
Application.DisplayAlerts = True 'active les alertes Windows comme lors d'une fusion de deux cellules avec valeurs.
    Range("A4").Select
    ActiveWindow.FreezePanes = True 'fige les lignes de 1 à 4
End Sub

cdt
galougalou

 

[djvinceathome]

re djvinceathome
une macro principale, ci-dessous et deux macros secondaires, mais qui auraient pu figurer dans le 1er
Je vous ai détaillé, pas à pas, les actions de la macro.
Quand vous la déclenchez, celle-ci identifie la feuille active et sa voisine précédente en stockant la position dans des variables.
Je vous laisse découvrir le principe de fonctionnement

Sub ventilation()
Dim F11 As Integer, F1 As Integer, F2 As Integer, i As Long, COL As Integer, couleur As Variant

Range("B4:AH100").Clear  'efface toute la plage, valeur,mise en forme, bordure,cellules fusionnées

ActiveWindow.FreezePanes = False 'desactive les cellules figées, ligne de 1 à 4
Application.ScreenUpdating = False 'desactive la mise à jour écran
Application.EnableEvents = False 'desactivé pour éviter le risque d'avoir une boucle sans fin d'action et de réaction.
 Application.DisplayAlerts = False 'desactive les alertes windows, par exemple lors d'une fusion de deux cellules avec valeurs
 
F11 = Sheets(1).index   'stocke dans la variable F11 la position de la 1re feuille du classeur
F1 = ActiveSheet.index 'stocke dans la variable F1 la position de la feuille active
If F1 > F11 Then  ' si f1 est plus grand que f11 alors
F2 = F1 - 1  'stocke la position de la feuille précédente de F1
End If


 li = Sheets(F1).Cells(36000, 1).End(xlUp).Row  ' dernière ligne avec valeurs de la 1re colonne de la feuille F1
ligne = Sheets(F2).Cells(36000, 2).End(xlUp).Row ' dernière ligne avec valeurs de la 2ᵉ colonne de la feuille F2

For COL = 2 To 35   'boucle sur colonne de 2 à 35 pour la feuille F1
For i = 4 To li   'boucle sur ligne de 4 à la fin pour la feuille F1
For i2 = 4 To ligne 'boucle sur ligne de 4 à la fin pour la feuille F2
If Sheets(F1).Cells(3, COL) = Sheets(F2).Cells(i2, 4) Then 'test sur l'activité
If Sheets(F1).Cells(i, 1) < Sheets(F2).Cells(i2, 6) Then 'test sur l'heure de fin
If Sheets(F1).Cells(i, 1) >= Sheets(F2).Cells(i2, 5) Then 'test sur l'heure de début

Sheets(F1).Cells(i, COL) = Sheets(F2).Cells(i2, 3)  'renvoie la colonne 3
Sheets(F1).Cells(i, COL).Interior.Color = Sheets(F2).Cells(i2, 3).Interior.Color 'récupère la couleur cellule
Sheets(F1).Cells(i, COL).Font.Color = Sheets(F2).Cells(i2, 3).Font.Color   'récupère la couleur police
If Sheets(F1).Cells(i, COL) = Sheets(F1).Cells(i - 1, COL) Then Sheets(F1).Range(Cells(i, COL), Cells(i - 1, COL)).Merge 'fusionne avec la cellule précédente
If Sheets(F1).Cells(i, COL) = Sheets(F1).Cells(i - 2, COL) Then Sheets(F1).Range(Cells(i, COL), Cells(i - 2, COL)).Merge  ' si plage cellule fusionne toute la plage
End If
End If
End If
Next
Next
Next
Call bordure 'exécute la macro bordure, bordure autour des cellules de la plage obligatoire, car l'instruction .clear en début de macro à effacée toutes les lignes
Call centre  'exécute la macro centre, écriture au centre de la cellule, nécessaire, car l'instruction .clear en début de macro à annuler cette disposition
Application.ScreenUpdating = True 'active la mise à jour de l'écran
Application.EnableEvents = True  'active les événements comme l'activation d'une feuille, une procédure double clic etc
Application.DisplayAlerts = True 'active les alertes Windows comme lors d'une fusion de deux cellules avec valeurs.
    Range("A4").Select
    ActiveWindow.FreezePanes = True 'fige les lignes de 1 à 4
End Sub

cdt
galougalou

Vous êtes génial, merci pour les infos, pouvez-vous me dire si je peux utiliser le même fichier pour faire une programmation de film à la place, du coup, j'encode des titres de films à diffuser dans une salle de cinéma avec les plages horaires. est-ce que je peux modifier le nom des feuilles ?

 

[djvinceathome]

Vous êtes génial, merci pour les infos, pouvez-vous me dire si je peux utiliser le même fichier pour faire une programmation de film à la place, du coup, j'encode des titres de films à diffuser dans une salle de cinéma avec les plages horaires. est-ce que je peux modifier le nom des feuilles ?

est-ce que dans la feuille besoin je peux écrire autant de ligne que je veux ?

 

[GALOUGALOU]

re
1er pour modifier le nom des feuilles aucun souci, car le principe de ce classeur, c'est de récupérer la feuille par son numéro d'index. La seule obligation, c'est que la feuille source soit voisine de la feuille destination, dans l'ordre source destination. Il n'y a pas de limite aux nombres de feuilles du classeur.

2ᵉ, dans la feuille besoin (donc source) il n'y pas de limite au nombre de lignes d'écriture, la macro trouvera la dernière ligne remplie sur la colonne 2 (donc B) mais en fonction de la construction du classeur vous pouvez modifier la colonne de référence (3 = c, 4 =d, etc)

ligne = Sheets(F2).Cells(36000, 2).End(xlUp).Row

 

[djvinceathome]

re
1er pour modifier le nom des feuilles aucun souci, car le principe de ce classeur, c'est de récupérer la feuille par son numéro d'index. La seule obligation, c'est que la feuille source soit voisine de la feuille destination, dans l'ordre source destination.
2eme, dans la feuille besoin (donc source) il n'y pas de limite au nombre de lignes d'écriture, la macro trouvera la dernière ligne remplie sur la colonne 2 (donc B) mais en fonction de la construction du classeur vous pouvez modifier la colonne de référence (3 = c, 4 =d, etc)

ligne = Sheets(F2).Cells(36000, 2).End(xlUp).Row

Merci pour l'info, je remarque un truc si je mets deux fois la même heure de début et de fin dans le même lieu, il remplace par le nouvelle quand je fais la mise à jour. Est-possible qu'il me dise que ce n'est pas possible pour cause de conflit.?

 

[GALOUGALOU]

Certainement,
voilà une question intéressante à poser sur le forum
Pour l'instant, je n'ai pas de réponse. Je vais réfléchir et essayer de trouver une solution. Mais je pense qu'il ne suffit pas de tester la même saisie, mais aussi la possibilité de chevauchement
cdt

 

[djvinceathome]

Merci pour l'info, je remarque un truc si je mets deux fois la même heure de début et de fin dans le même lieu, il remplace par le nouvelle quand je fais la mise à jour. Est-possible qu'il me dise que ce n'est pas possible pour cause de conflit.?

Certainement,
voilà une question intéressante à poser sur le forum
Pour l'instant, je n'ai pas de réponse. Je vais réfléchir et essayer de trouver une solution. Mais je pense qu'il ne suffit pas de tester la même saisie, mais aussi la possibilité de chevauchement
cdt

RE,

Dans les faits, ce n'est pas possible d'avoir deux activités sur le même lieu. mais un message d'erreur qui dit que cette plage est déjà prise pour une autre activité.

 

[GALOUGALOU]

re
dans la feuille source cette formule matricielle va identifier les chevauchements sur la salle, date début, date fin
la formule ci-dessous va identifier les chevauchements et les comptabiliser; et une mfc associé va identier de rouge les lignes problèmatiques

{=SI(D4>1;SOMMEPROD(($E$4:$E$50<=$F4)*($F$4:$F$50>=$E4)*($D4=$D$4:$D$50)))}

dans le classeur ci-dessous , à la date du 2 octobre, faites des essais en modifiant les heures de bomel. si chevauchement au moment de la saisie, les lignes s'éclaireront de rouge.
Conclusion, tout chevauchement provoquera une alerte rouge.
de plus, la macro va vérifier le résultat de cette formule dans la cellule m1

=SIERREUR(RECHERCHEV(2;M4:M50;1;FAUX);"")

si la formule renvoie "2", alors la macro s'arrêtera et sélectionnera l'onglet à corriger.

Par la même occasion, dans ce classeur la macro principale est un peu plus aboutie.
en début de procédure dans des variables, seront stockés les réglages excel, ensuite les exécutions automatiques sont désactivées le temps de la macro et les réglages d'origine sont rétablis en fin de procédure
ex : si avant la macro le calcul est en manuel, ce réglage sera rétabli en fin de procédure
cdt
galougalou

 

[GALOUGALOU]

re
une meilleure gestion des cellules fusionnées avec cette macro

Sub fusion_colonnes()
Dim l As Long       ' ligne
Dim d As Long       ' doubles
Dim c As Integer    ' colonne
Const minl = 4      ' début ligne
Const maxl = 82      ' fin ligne
Const minc = 2     ' début colonne
Const maxc = 35      ' fin colonne

For c = minc To maxc
    For l = minl To maxl
    
        For d = l + 1 To maxl
            If (Cells(l, c) <> Cells(d, c)) Then Exit For
        Next d
        
        If Cells(l, c) <> "" Then
        If d > l + 1 Then
            With Cells(l, c).Resize(d - l, 1)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .WrapText = True 'False
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .Font.Bold = True
                .MergeCells = True
            End With
        End If
        End If
    Next l
Next c

End Sub

cdt
galougalou

 

[djvinceathome]

re
une meilleure gestion des cellules fusionnées avec cette macro

Sub fusion_colonnes()
Dim l As Long       ' ligne
Dim d As Long       ' doubles
Dim c As Integer    ' colonne
Const minl = 4      ' début ligne
Const maxl = 82      ' fin ligne
Const minc = 2     ' début colonne
Const maxc = 35      ' fin colonne

For c = minc To maxc
    For l = minl To maxl
   
        For d = l + 1 To maxl
            If (Cells(l, c) <> Cells(d, c)) Then Exit For
        Next d
       
        If Cells(l, c) <> "" Then
        If d > l + 1 Then
            With Cells(l, c).Resize(d - l, 1)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .WrapText = True 'False
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .Font.Bold = True
                .MergeCells = True
            End With
        End If
        End If
    Next l
Next c

End Sub

cdt
galougalou

Hello,

Désolé pour la réponse tardive, mais d'avance je te remercie, je n'ai pas encore regarder le résultat mais je t'en tiendrai informé. Je reviens de congé donc déso...

 

[djvinceathome]

re
une meilleure gestion des cellules fusionnées avec cette macro

Sub fusion_colonnes()
Dim l As Long       ' ligne
Dim d As Long       ' doubles
Dim c As Integer    ' colonne
Const minl = 4      ' début ligne
Const maxl = 82      ' fin ligne
Const minc = 2     ' début colonne
Const maxc = 35      ' fin colonne

For c = minc To maxc
    For l = minl To maxl
   
        For d = l + 1 To maxl
            If (Cells(l, c) <> Cells(d, c)) Then Exit For
        Next d
       
        If Cells(l, c) <> "" Then
        If d > l + 1 Then
            With Cells(l, c).Resize(d - l, 1)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .WrapText = True 'False
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .Font.Bold = True
                .MergeCells = True
            End With
        End If
        End If
    Next l
Next c

End Sub

cdt
galougalou

Bonjour,

J'ai besoin d'une explication sur le tableau, comment les deux feuilles font le lien entre elle. Je m'explique, comment Excel sait qui doit se positionner entre le lieu et l'heure sur la feuille 2 ? Comment sait-il qu'il doit reprendre l'activité et non pas une autre cellule? Comment tout cela est exprimé dans la VB ? Merci pour la version 7 du soft Excel. tu es génial ....

 

[djvinceathome]

re
dans la feuille source cette formule matricielle va identifier les chevauchements sur la salle, date début, date fin
la formule ci-dessous va identifier les chevauchements et les comptabiliser; et une mfc associé va identier de rouge les lignes problèmatiques

{=SI(D4>1;SOMMEPROD(($E$4:$E$50<=$F4)*($F$4:$F$50>=$E4)*($D4=$D$4:$D$50)))}

dans le classeur ci-dessous , à la date du 2 octobre, faites des essais en modifiant les heures de bomel. si chevauchement au moment de la saisie, les lignes s'éclaireront de rouge.
Conclusion, tout chevauchement provoquera une alerte rouge.
de plus, la macro va vérifier le résultat de cette formule dans la cellule m1

=SIERREUR(RECHERCHEV(2;M4:M50;1;FAUX);"")

si la formule renvoie "2", alors la macro s'arrêtera et sélectionnera l'onglet à corriger.

Par la même occasion, dans ce classeur la macro principale est un peu plus aboutie.
en début de procédure dans des variables, seront stockés les réglages excel, ensuite les exécutions automatiques sont désactivées le temps de la macro et les réglages d'origine sont rétablis en fin de procédure
ex : si avant la macro le calcul est en manuel, ce réglage sera rétabli en fin de procédure
cdt
galougalou

Bonjour,
Lorsque je mets plus de deux fois Bomel avec des heures qui se chevauchent cela ne fonctionne pas ou je fais une mauvaise manip...