Fusionner Cellules entre 2 dates

Bonjour,

J'aimerais que Excel me fusionne les cellules entre 2 dates automatiquement et qu'il insère un nom à cette cellule fusionnée.

Vous trouverez dans le fichier ce que j'aimerais au final.

Merci à tous

Bonne journée

Jaan

Salut Jan,

fusionner des cellules = rarement bon !
J'ai donc fait à ma sauce avec un résultat identique malgré tout à ce que tu souhaites.

- tu peux sélectionner ta période directement dans les cellules-calendrier : les dates en [B:C] se mettront à jour automatiquement :
- pour sélectionner une période de UN jour, tu sélectionnes cette date dans les cellules-calendrier d'un clic DROIT ;
- tu peux commander l'affichage d'une période en sélectionnant les deux cellules [B:C] ;
- tu peux modifier les dates manuellement : si la date en [C] est antérieure à celle en [B], la cellule modifiée se colore de rouge sans, évidemment d'affichage possible dans le calendrier.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
Dim iRowEND%, iRow%, iColEND%, iColT1%, iColT2%
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
iColEND = Cells(1, Columns.Count).End(xlToLeft).Column
iRowEND = Range("A" & Rows.Count).End(xlUp).Row
'
If Selection.Rows.Count = 1 And Selection.Columns.Count > 1 Then
    iRow = Target.Row
    If Not Intersect(Target, Range("D2").Resize(iRowEND, iColEND)) Is Nothing Then
        With Selection
            If .Cells(1, 1).Interior.Color <> xlNone Or .Cells(1, .Columns.Count).Interior.Color <> xlNone Then Call Nettoyage(iRow, iColEND)
            iColT1 = Selection.Column - 1
            iColT2 = Selection.Columns.Count
            Call DrawSelection(Range("A" & iRow).Offset(0, iColT1).Resize(1, iColT2))
        End With
    End If
    '
    If Not Intersect(Target, Range("B2").Resize(iRowEND, 2)) Is Nothing Then _
        If WorksheetFunction.CountA(Selection) = 2 Then _
            Call Nettoyage(iRow, iColEND): _
            iColT1 = Rows(1).Find(what:=Range("B" & iRow).Value, lookat:=xlWhole, LookIn:=xlFormulas).Column - 1: _
            iColT2 = Rows(1).Find(what:=Range("C" & iRow).Value, lookat:=xlWhole, LookIn:=xlFormulas).Column: _
            Call DrawSelection(Range("A" & iRow).Offset(0, iColT1).Resize(1, iColT2 - iColT1))
End If
'
Application.EnableEvents = True
Application.ScreenUpdating = True
'
End Sub

A+