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

  • exemple tableau.xlsm
    46.4 KB · Affichages: 67
  • exemple tableau.xlsm
    46.4 KB · Affichages: 62
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

  • exemple tableau(1).xlsm
    52.2 KB · Affichages: 53
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

  • exemple tableau(2).xlsm
    52.9 KB · Affichages: 53
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

  • exemple tableau(3).xlsm
    91 KB · Affichages: 61
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

  • exemple tableau(4).xlsm
    115 KB · Affichages: 42
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

Roseline
  • Résolu(e)
Microsoft 365 Additionner 36 heures à des dates et heures
Réponses
5
Affichages
258
TooFatBoy
TooFatBoy
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
1 K
Manutela
M
N
  • Résolu(e)
XL 2021 détermination des heures de pause automatique en fonction de case vide
Réponses
10
Affichages
260
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
993
Cousinhub
Cousinhub
G
  • 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
3 K
GILBERTO BRAGA
G
G
  • 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
387
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
575
Phil69970
Phil69970
C
  • Question
Microsoft 365 Horaire, convertir des cellules avec texte en heure début et fin
2
Réponses
23
Affichages
1 K
patricktoulon
patricktoulon
L
  • Question
XL pour MAC tableau ans perturbation des colonnes non copié
Réponses
5
Affichages
379
DJunqueira
D
N
  • Résolu(e)
XL 2016 créer un tableau qui contient tous les distances entre les stations de bus
Réponses
4
Affichages
310
nasri badreddine
N

Membres actuellement en ligne

9 membres et 86 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 490
Messages
2 088 879
Membres
103 981
dernier inscrit
vinsalcatraz