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
Merci beaucoup super travail ! Bon week-end à vous !Bonjour,
Proposition par deux boutons et leur macro respective :
1 - Archiver
2 - Nettoyer
Cordialement
Super boulot comme d'habitude ! Je préfère cette manière plus ordonner mais tous les 2 super travail ! Bon week-end à vous !Bonjour Chinel, Hasco,
(Edit: J'ai modifié le code suite à bug.)
Une autre approche en PJ. L'archivage se fait si on tente de modifier la date.
J'ai modifié l'entrée mois/année pour simplifier. Avec en Feuil1 :
VB: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