Const deb$ = "A5" 'adresse de la 1ère cellule du tableau, à adapter
Const nfusion% = 10 'nombre de cellules fusionnées par ligne, à adapter
Const col1% = 11 'colonne de Date 1, à adapter
Const col2% = 12 'colonne de Date 2, à adapter
Const col3% = 13 'colonne de Date 3, à adapter
Private Sub Worksheet_Change(ByVal Target As Range)
Dim coldeb%, P As Range, r As Range, i&, n, j%
coldeb = Range(deb).Column
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Set P = Range(deb).CurrentRegion
If Intersect(Target, P) Is Nothing Then GoTo 1
'---contrôle des dates---
Set r = Intersect(Target, P.Offset(1), Union(P.Columns(col1), P.Columns(col2), P.Columns(col3)))
If Not r Is Nothing Then
For Each r In r 'si entrées/effacements multiples
If r <> "" And Not IsDate(r) Then r = "": r.Select
Next
End If
'---insertion de lignes---
If Not Intersect(Target, P.Offset(1).Columns(col2)) Is Nothing And Target.Count = 1 Then
Set r = Cells(Target.Row, coldeb).MergeArea
i = r.Count
If Application.CountA(r.Offset(, col2 - 1).Resize(i)) = i Then
Application.ScreenUpdating = True
n = 1
Do
n = Abs(Int(Val(InputBox("Entrer 1 2 ou 3 pour insérer des lignes :", "Insertion", n))))
Loop While n > 3
Application.ScreenUpdating = False
If n Then
Target(2).EntireRow.Resize(n).Insert
For j = 0 To nfusion - 1
r.Offset(, j).Resize(i + n).Merge
Next
End If
End If
End If
'---formule du N° d'ordre pour la MFC couleur---
Set r = Intersect(Target, Range(deb).CurrentRegion)
If r Is Nothing Then GoTo 1
i = Range(deb).Row
For Each r In r 'si entrées/effacements multiples
Set r = Cells(r.Row, coldeb).MergeArea
If r.Row > i Then r = IIf(Application.Count(r.Offset(, col3 - 1).Resize(r.Count)), "=MAX(R5C:R[-1]C)+1", "#")
Next
1 With Range(deb).CurrentRegion
'---suppression des bordures---
.Resize(Rows.Count - .Row + 1).Borders.LineStyle = xlNone
'---défusion des cellules sous le tableau si effacements---
.Offset(.Rows.Count).Resize(Rows.Count - .Rows.Count - .Row + 1).UnMerge
'---création de nouvelles bordures---
.Borders.Weight = xlThin
'---reconstruction de la MFC---
.Resize(Rows.Count - .Row + 1).FormatConditions.Delete
Set r = Selection
.Select 'indispensable sur les versions antérieures à 2007
.Cells(1) = "=MOD(1/(MATCH(""zzz"",$A$5:$A5)<MATCH(9^9,$A$5:$A5))*MAX($A$5:$A5),2)"
.FormatConditions.Add xlExpression, Formula1:=.Cells(1).FormulaLocal
.Cells(1) = "=NOT(MOD(1/(MATCH(""zzz"",$A$5:$A5)<MATCH(9^9,$A$5:$A5))*MAX($A$5:$A5),2))"
.FormatConditions.Add xlExpression, Formula1:=.Cells(1).FormulaLocal
.Cells(1) = "N° d'ordre"
.FormatConditions(1).Interior.ColorIndex = 35 'vert
.FormatConditions(2).Interior.ColorIndex = 20 'bleu
r.Select
End With
Application.EnableEvents = True 'réactive les évènements
End Sub