Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo Fin
'If Target.Count > 5 Then Exit Sub
If Not Intersect(Target, Range("B2:I2")) Is Nothing Then
Réponse = MsgBox("Vous êtes sur le point de modifier la date de début." & Chr(10) & "Voulez vous archiver avant ?", vbYesNo + vbQuestion, "ATTENTION")
If Réponse = vbNo Then Exit Sub
Application.EnableEvents = False
Archiver
Application.EnableEvents = True
End If
Fin:
End Sub
Sub Archiver()
Application.ScreenUpdating = False
With Sheets("Archivage")
DL = Range("C65500").End(xlUp).Row
For L = 7 To DL
On Error Resume Next
Colonne = Application.Match(Cells(L, "C"), .[1:1], 0)
If IsError(Colonne) Then ' Nom n'existe pas
.Cells(1, 1 + .Cells(1, .Columns.Count).End(xlToLeft).Column) = Cells(L, "C")
Colonne = .Cells(1, .Columns.Count).End(xlToLeft).Column
End If
Ligne = 1 + .Cells(65000, Colonne).End(xlUp).Row
For C = 4 To 34
If LCase(Cells(L, C)) = "x" Then
.Cells(Ligne, Colonne) = Cells(6, C)
Ligne = 1 + .Cells(65000, Colonne).End(xlUp).Row
End If
Next C
Next L
.Columns.AutoFit
End With
Range("D7:AH" & DL).ClearContents
End Sub