fusionner des cellules dans un tableau entre une heure de début et une heure de fin

J

jujux265

XLDnaute Nouveau
Bonjour,
J'aimerai à partir de la date ligne 5 exemple : 10/12/2015 ( trouvée en colonne J) trouver l'intersection entre J5 et la valeur de la cellule 3 fois en dessous de J5 (à savoir 07h50 sur cet exemple) trouvé dans la colonne A ( à savoir dans l'exemple A11) soit intersection = cellule J11 dans l'exemple idem pour l'heure de fin 08h30 donc intersection J16 fusionner J11jusqu'a J16 merci pour votre aide,
Et pouvoir faire cela a chaque fois que je rempli une autre colonne avec d'autres horaires ( la date sera toujour sur la ligne 5 et l'heure de début ligne 8 heure de fin ligne 9 )
la cellule fusionnée suivant la valeur des heures début et fin correspondant aux lignes trouvées en colonne A et évidemment la colonne du jour en ligne 5,
fichier joint
Si quelqu'un peut m'aider ça serait sympa
 

Pièces jointes

Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Re : fusionner des cellules dans un tableau entre une heure de début et une heure de

Bonjour jujux265,

A placer dans le code de la feuille :

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, a As Range, b As Range, c As Range, i As Variant, j As Variant
Set r = Intersect(Target, [C8:Y9])
If r Is Nothing Then Exit Sub
For Each r In r 'en cas d'entrées multiples (copier-coller par exemple)
  Set a = Intersect(r.EntireColumn, [11:17])
  Set b = Intersect(r.EntireColumn, [20:31])
  Set c = Intersect(r.EntireColumn, [35:52])
  a.UnMerge: b.UnMerge: c.UnMerge 'RAZ
  i = Application.Match(r(9 - r.Row), [A11:A17], 0)
  j = Application.Match(r(10 - r.Row), [A11:A17], 0)
  If IsNumeric(i) And IsNumeric(j) Then Range(a(i), a(j)).Merge: GoTo 1
  i = Application.Match(r(9 - r.Row), [A20:A31], 0)
  j = Application.Match(r(10 - r.Row), [A20:A31], 0)
  If IsNumeric(i) And IsNumeric(j) Then Range(b(i), b(j)).Merge: GoTo 1
  i = Application.Match(r(9 - r.Row), [A35:A52], 0)
  j = Application.Match(r(10 - r.Row), [A35:A52], 0)
  If IsNumeric(i) And IsNumeric(j) Then Range(c(i), c(j)).Merge
1 Next
End Sub
Nota : il faut entrer 09h30 et pas 9h30...

A+
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : fusionner des cellules dans un tableau entre une heure de début et une heure de

Bonjour jujux2565,

Une solution nettement plus élaborée avec :

- RAZ et bordures des cellules défusionnées

- entrée du texte et de la couleur dans les cellules fusionnées.

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, a As Range, b As Range, c As Range
Dim coul&, cel As Range, i As Variant, j As Variant
Set r = Intersect(Target, [C6:Y10])
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
For Each r In r 'en cas d'entrées multiples (copier-coller par exemple)
  Set a = Intersect(r.EntireColumn, [11:17])
  Set b = Intersect(r.EntireColumn, [20:31])
  Set c = Intersect(r.EntireColumn, [35:52])
  coul = 16777215 'incolore
  'coul = 16751103 'rose
  '---cellules défusionnées---
  For Each cel In Union(a, b, c)
    If cel.MergeCells Then
      With cel.MergeArea
        .UnMerge
        coul = cel.Interior.Color 'mémorisation couleur
        .Borders(xlInsideHorizontal).Weight = xlThin 'bordures
      End With
      Exit For
    End If
  Next cel
  Union(a, b, c) = "" 'RAZ
  Union(a, b, c).Interior.ColorIndex = xlNone 'effacement couleur
  '---cellules fusionnées---
  i = Application.Match(r(9 - r.Row), [A11:A17], 0)
  j = Application.Match(r(10 - r.Row), [A11:A17], 0)
  If IsNumeric(i) And IsNumeric(j) Then
    Range(a(i), a(j)).Merge
    a(i) = r(7 - r.Row) & " - " & r(8 - r.Row) & " " & r(11 - r.Row)
    a(i).WrapText = True: a(i).Interior.Color = coul: GoTo 1
  End If
  i = Application.Match(r(9 - r.Row), [A20:A31], 0)
  j = Application.Match(r(10 - r.Row), [A20:A31], 0)
  If IsNumeric(i) And IsNumeric(j) Then
    Range(b(i), b(j)).Merge
    b(i) = r(7 - r.Row) & " - " & r(8 - r.Row) & " " & r(11 - r.Row)
    b(i).WrapText = True: b(i).Interior.Color = coul: GoTo 1
  End If
  i = Application.Match(r(9 - r.Row), [A35:A52], 0)
  j = Application.Match(r(10 - r.Row), [A35:A52], 0)
  If IsNumeric(i) And IsNumeric(j) Then
    Range(c(i), c(j)).Merge
    c(i) = r(7 - r.Row) & " - " & r(8 - r.Row) & " " & r(11 - r.Row)
    c(i).WrapText = True: c(i).Interior.Color = coul
  End If
1 Next r
End Sub
Edit : j'ai initialisé la variable coul

Fichier joint.

Joyeux Noël à tous.
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : fusionner des cellules dans un tableau entre une heure de début et une heure de

Bonjour jujux265, le forum,

On peut aussi prévoir une couleur différente pour chaque jour de la semaine :

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, a As Range, b As Range, c As Range
Dim coul&, z As Range, i As Variant, j As Variant
Set r = Intersect(Target, [C5:Y10])
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
For Each r In r 'en cas d'entrées multiples (copier-coller par exemple)
  Set a = Intersect(r.EntireColumn, [11:17])
  Set b = Intersect(r.EntireColumn, [20:31])
  Set c = Intersect(r.EntireColumn, [35:52])
  coul = [Couleurs].Cells(Weekday(r(6 - r.Row), 2)).Interior.Color
  '---cellules défusionnées---
  For Each z In Union(a, b, c).Areas
    z.UnMerge
    z = "" 'RAZ
    z.Interior.ColorIndex = xlNone 'effacement couleur
    z.Borders(xlInsideHorizontal).Weight = xlThin 'bordures
  Next z
  '---cellules fusionnées---
  i = Application.Match(r(9 - r.Row), [A11:A17], 0)
  j = Application.Match(r(10 - r.Row), [A11:A17], 0)
  If IsNumeric(i) And IsNumeric(j) Then
    Range(a(i), a(j)).Merge
    a(i) = r(7 - r.Row) & " - " & r(8 - r.Row) & " " & r(11 - r.Row)
    a(i).WrapText = True: a(i).Interior.Color = coul: GoTo 1
  End If
  i = Application.Match(r(9 - r.Row), [A20:A31], 0)
  j = Application.Match(r(10 - r.Row), [A20:A31], 0)
  If IsNumeric(i) And IsNumeric(j) Then
    Range(b(i), b(j)).Merge
    b(i) = r(7 - r.Row) & " - " & r(8 - r.Row) & " " & r(11 - r.Row)
    b(i).WrapText = True: b(i).Interior.Color = coul: GoTo 1
  End If
  i = Application.Match(r(9 - r.Row), [A35:A52], 0)
  j = Application.Match(r(10 - r.Row), [A35:A52], 0)
  If IsNumeric(i) And IsNumeric(j) Then
    Range(c(i), c(j)).Merge
    c(i) = r(7 - r.Row) & " - " & r(8 - r.Row) & " " & r(11 - r.Row)
    c(i).WrapText = True: c(i).Interior.Color = coul
  End If
1 Next r
End Sub
Fichier (2).

Très bonne journée.
 

Pièces jointes

Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : fusionner des cellules dans un tableau entre une heure de début et une heure de

Re,

J'ai essayé de faire des MFC pour les "Mois précédent", "Mois suivant", "Jour Férié" mais ça ne va pas.

Bonne nuit.
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : fusionner des cellules dans un tableau entre une heure de début et une heure de

Bonjour jujux265, le forum,

Dans ce fichier (3) j'ai ajouté les mois de Janvier 2016 et Février 2016.

Une seule macro suffit, dans ThisWorkbook :

Code: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim r As Range, a As Range, b As Range, c As Range
Dim coul&, z As Range, i As Variant, j As Variant
Set r = Intersect(Target, Sh.[B5:Z10])
If r Is Nothing Or Not IsDate("1 " & Sh.Name) Then Exit Sub
Application.ScreenUpdating = False
For Each r In r 'en cas d'entrées multiples (copier-coller par exemple)
  Set a = Intersect(r.EntireColumn, [11:17])
  Set b = Intersect(r.EntireColumn, [20:31])
  Set c = Intersect(r.EntireColumn, [35:52])
  coul = [Couleurs].Cells(Weekday(r(6 - r.Row), 2)).Interior.Color
  '---cellules défusionnées---
  For Each z In Union(a, b, c).Areas
    z.UnMerge
    z = "" 'RAZ
    If LCase(r(7 - r.Row)) = "mois" Or LCase(r(7 - r.Row)) = "jour" Then
      z.Interior.Color = Sh.[B4].Interior.Color 'gris clair
      z.Borders(xlInsideHorizontal).LineStyle = xlNone 'suppression bordures
    Else
      z.Interior.ColorIndex = xlNone 'effacement couleur
      z.Borders(xlInsideHorizontal).Weight = xlThin 'bordures
    End If
  Next z
  '---cellules fusionnées---
  i = Application.Match(r(9 - r.Row), [A11:A17], 0)
  j = Application.Match(r(10 - r.Row), [A11:A17], 0)
  If IsNumeric(i) And IsNumeric(j) Then
    Range(a(i), a(j)).Merge
    a(i) = r(7 - r.Row) & " - " & r(8 - r.Row) & " " & r(11 - r.Row)
    a(i).WrapText = True: a(i).Interior.Color = coul: GoTo 1
  End If
  i = Application.Match(r(9 - r.Row), [A20:A31], 0)
  j = Application.Match(r(10 - r.Row), [A20:A31], 0)
  If IsNumeric(i) And IsNumeric(j) Then
    Range(b(i), b(j)).Merge
    b(i) = r(7 - r.Row) & " - " & r(8 - r.Row) & " " & r(11 - r.Row)
    b(i).WrapText = True: b(i).Interior.Color = coul: GoTo 1
  End If
  i = Application.Match(r(9 - r.Row), [A35:A52], 0)
  j = Application.Match(r(10 - r.Row), [A35:A52], 0)
  If IsNumeric(i) And IsNumeric(j) Then
    Range(c(i), c(j)).Merge
    c(i) = r(7 - r.Row) & " - " & r(8 - r.Row) & " " & r(11 - r.Row)
    c(i).WrapText = True: c(i).Interior.Color = coul
  End If
1 Next r
End Sub
Nota : voyez les formules en ligne 5, il suffit de modifier B5 quand on crée le mois.

A+
 

Pièces jointes

Vote positif 0 Vote négatif
J

jujux265

XLDnaute Nouveau
Re : fusionner des cellules dans un tableau entre une heure de début et une heure de

Merci pour votre gentillesse mais le fait de passer avec le workbook m bloque lorsque l'agent ( avec un userform) désire s'inscrire sur une journée bloquée par un formateur. erreur je ne peux pas mettre à jour le nom de l'agent ni la session désiré.
Merci quand même Bonne fêtes à vous et à vos proches
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : fusionner des cellules dans un tableau entre une heure de début et une heure de

Bonjour jujux265, le forum,

Par MP vous m'avez parlé d'une couleur pour chaque formateur.

Alors voyez ce fichier (4).

J'ai aussi introduit la plage P pour traiter complètement les formats des lignes 6 à 10 :

Code: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim r As Range, P As Range, Z As Range, testjour As Boolean, i As Variant, j As Variant
Set r = Intersect(Target, Sh.[B5:Z10])
If r Is Nothing Or Not IsDate("1 " & Sh.Name) Then Exit Sub
Application.ScreenUpdating = False
For Each r In r 'en cas d'entrées multiples (copier-coller par exemple)
  Set P = Intersect(r.EntireColumn, Sh.[6:10])
  Set Z = Intersect(r.EntireColumn, Sh.[11:17,20:31,35:52])
  testjour = LCase(P(1)) = "mois" Or LCase(P(1)) = "jour"
  '---zone P---
  If testjour Then
    P.Interior.Color = Sh.[B4].Interior.Color 'gris clair
    P.Borders(xlInsideHorizontal).LineStyle = xlNone 'suppression bordures
    P.HorizontalAlignment = xlCenter 'centrage
    P.ColumnWidth = 10 'largeur colonne
  Else
    P.Interior.Color = Sh.[B5].Interior.Color
    i = Application.Match(P(1), [Formateurs], 0)
    If IsNumeric(i) Then P(1).Interior.Color = [Couleurs].Cells(i).Interior.Color
    P.Borders(xlInsideHorizontal).Weight = xlThin 'bordures
    P.HorizontalAlignment = xlLeft
    P.ColumnWidth = 14 'largeur colonne
  End If
  '---zones Z---
  Z.UnMerge 'défusion
  Z = "" 'RAZ
  For Each Z In Z.Areas
    If testjour Then
      Z.Interior.Color = Sh.[B4].Interior.Color 'gris clair
      Z.Borders(xlInsideHorizontal).LineStyle = xlNone 'suppression bordures
    Else
      Z.Interior.ColorIndex = xlNone 'effacement couleur
      Z.Borders(xlInsideHorizontal).Weight = xlThin 'bordures
      If P(3) <> "" And P(4) <> "" Then
        i = Application.Match(P(3), Z.Columns(2 - r.Column), 0)
        j = Application.Match(P(4), Z.Columns(2 - r.Column), 0)
        If IsNumeric(i) And IsNumeric(j) Then
          Range(Z(i), Z(j)).Merge 'fusion
          Z(i).WrapText = True: Z(i) = P(1) & " - " & P(2) & " " & P(5)
          Z(i).Interior.Color = P(1).Interior.Color
        End If
      End If
    End If
Next Z, r
End Sub
Edit : les variables a b c étaient inutiles.

A+
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

N
  • Question Question
XL 2021 déterminer heure de début et fin + pause en fonction de cellules de couleurs.
2
Réponses
17
Affichages
669
natadom
N
E
  • Question Question
extraire une date de début et de fin dans un calendrier excel avec une valeur répé
Réponses
5
Affichages
307
AtTheOne
AtTheOne
M
  • Question Question
Autres Mettre en couleur des cellules depuis une date de début jusqu'a la date de fin
Réponses
10
Affichages
284
mcl
M
O
  • Résolu(e)
Microsoft 365 Effacer le contenu de cellules si une autre cellule est vide
Réponses
9
Affichages
239
Olihoes
O
Adexa
  • Question Question
XL 2019 Rechercher un libellé approximatif dans un tableau et afficher une valeur
2
Réponses
29
Affichages
881
Dudu2
Dudu2
StephCo
  • Question Question
Autres Diagramme de Gantt avec beaucoup de contraintes (avec LibreOffice) et formule matricielle multicritères
Réponses
2
Affichages
633
Simon 1234
S
Roseline
  • Résolu(e)
Microsoft 365 Additionner 36 heures à des dates et heures
Réponses
5
Affichages
584
TooFatBoy
TooFatBoy
C
  • Question Question
XL 2010 Recherche de colonne et calcul sur 2 années consécutives
Réponses
0
Affichages
225
CS49
C
chris6999
  • Question Question
Microsoft 365 Copier une plage vers une autre feuille depuis un USF
Réponses
4
Affichages
202
chris6999
chris6999
M
  • Résolu(e)
XL 2013 Calcul des heures travaillées de jour, de nuit et plus de 24h consécutives
2 3
Réponses
41
Affichages
2 K
Manutela
M
R
  • Résolu(e)
XL 2016 Somme par année en fonction d'une date de début et de fin
Réponses
4
Affichages
697
remyexcel
R
N
  • Résolu(e)
XL 2021 détermination des heures de pause automatique en fonction de case vide
Réponses
10
Affichages
431
natadom
N
N
  • Résolu(e)
XL 2021 Power Query somme des fin de journée où il y a juste une heure de commencement ?
2
Réponses
19
Affichages
1 K
Cousinhub
Cousinhub
J
  • Résolu(e)
Autres Créer des liens hypertexte automatiques et dans plusieurs colonnes dans un tableau excel
Réponses
8
Affichages
267
JMC
J
G
  • Question Question
Microsoft 365 Calcul des heures normales et des heures supplémentaires, les heures de nuit étant modifiées en fonction du début de la journée de travail.
2 3 4
Réponses
58
Affichages
4 K
GILBERTO BRAGA
G
G
  • Question Question
XL 2016 Répartition mensuelle de la charge par équipe en fonction d'une date de début et d'une date de fin
Réponses
4
Affichages
647
Lolote83
L
chaelie2015
  • Résolu(e)
XL 2013 Gestion Automatisée des Dates en Fonction des Périodes et des Mois
Réponses
9
Affichages
793
Phil69970
Phil69970
W
  • Résolu(e)
XL 2016 Gestion de liste transposée dans une autre feuille avec décalage d'une colonne et exclusion de certains éléments
Réponses
9
Affichages
435
Webperegrino
W
jeff1494
  • Question Question
XL 2021 Besoin de conseils pour une sélection de multiples éléments
2
Réponses
18
Affichages
1 K
jeff1494
jeff1494
C
  • Résolu(e)
Copier/Masquer des lignes de couleur pour alimenter un tableau
Réponses
9
Affichages
570
vgendron
vgendron

Membres actuellement en ligne

19 membres et 396 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 285
Messages
2 118 026
Membres
113 414
dernier inscrit
AmadouK