Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

Créer une discussion

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
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
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
Re : fusionner des cellules dans un tableau entre une heure de début et une heure de

merci mais je n'ai pas tout compris tu peux me le faire sur le fichier et me le renvoyer STP ( excuse j'ai des limites avec la programmation) merci beaucoup
 
Vote positif 0 Vote négatif
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
Re : fusionner des cellules dans un tableau entre une heure de début et une heure de

de même joyeux noël à tous et merci je regarde cela des que je peux ce soir c'est la fête Profitez en un maximum ( sans être malade);-)
 
Vote positif 0 Vote négatif
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
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
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
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
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
Identifiez-vous ou inscrivez-vous pour participer.
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

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
853
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
411
AtTheOne
W
  • Résolu(e)
XL 2019 Retirer un mot dans un pavé de cellules contenant des Vblf
2
Réponses
21
Affichages
420
Webperegrino
W
P
  • Résolu(e)
XL 2016 VBA Insérer une date dans le nom de fichiers PDF publipostés via WORD à partir d"excel
Réponses
3
Affichages
508
PHIL37
P
O
  • Résolu(e)
Microsoft 365 Effacer le contenu de cellules si une autre cellule est vide
Réponses
9
Affichages
467
Olihoes
O
C
Excel : Fusionner des cellules en conservant le contenu et la police des cellules à fusionner
Réponses
5
Affichages
655
crocrocro
C
T
  • Question Question
XL 2019 dans un tableau ( mise en forme de tableau), 2 couleur pour 1 tableau
Réponses
4
Affichages
370
tuti
T
A
  • Résolu(e)
Microsoft 365 Insérer un résultat dans une cellule d'un tableau
Réponses
5
Affichages
272
Alain 79
A
P
  • Résolu(e)
XL 2019 Tri sur une ligne dans un tableau.
Réponses
4
Affichages
264
Paulle
P
J
  • Question Question
Microsoft 365 Naviguer dans un tableau pour copier des données dans un modèle et copier l'un derrière l'autre
Réponses
11
Affichages
403
AtTheOne
  • Question Question
XL 2019 Rechercher un libellé approximatif dans un tableau et afficher une valeur
2
Réponses
29
Affichages
1 K
Dudu2
D
  • Question Question
XL 2019 Suppression doublons combinés entre deux cellules associées et présentation sous forme de tableau
Réponses
13
Affichages
720
alexga78
A
A
  • Résolu(e)
XL 2016 Recherche d'un mot dans une cellule et surlignage de la ligne
Réponses
4
Affichages
459
Abi23
A
  • Résolu(e)
Microsoft 365 Additionner 36 heures à des dates et heures
Réponses
5
Affichages
674
TooFatBoy
  • Question Question
Autres Diagramme de Gantt avec beaucoup de contraintes (avec LibreOffice) et formule matricielle multicritères
Réponses
2
Affichages
804
Simon 1234
S
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
2 K
Cousinhub
  • Question Question
XL 2021 Besoin de conseils pour une sélection de multiples éléments
2
Réponses
18
Affichages
1 K
jeff1494
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
816
remyexcel
R
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
807
Lolote83
L
J
  • Résolu(e)
XL 2019 Détection de texte dans une Cellule pour le Copier et Coller dans un autre tableau
2 3
Réponses
40
Affichages
2 K
Phil69970
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…