Private Sub Worksheet_Change(ByVal Cible As Range)
Dim i&, j&, tmp%, EtatCalc&, An(), Ref As Range, Plg As Range, Col As Range, Cel As Range
' Paramètre unique de la procédure : Première cellule du tableau de données.
Set Ref = [B3]
' Recherche des données à traiter. Les données à traiter sont les cellules qui ont appelé
'la procédure et qui sont situées dans la colonne 'Ref.Column' en dessous de 'Ref' :
Set Plg = Intersect(Ref.Resize(Rows.Count - Ref.Row, Ref.Column).Offset(1), Cible)
' Si 'Plg' est vide (i.e. si aucune des cellules qui ont appelé la procédure n'est dans
'la colonne 'Ref.Column' en dessous de 'Ref'), on ne fait rien. Sinon :
If Not Plg Is Nothing Then
EtatCalc = Application.Calculation
' Ligne "technique" visant à accélerer la procédure.
With Application: .ScreenUpdating = 0: .Calculation = -4135: End With
' On place dans un 'An' les valeurs de 'Ref' et des cellules situées à droite de 'Ref' :
An = Ref.Resize(1, Ref.End(xlToRight).Column).Value
' On traite tour à tour chacune des cellules de 'Plg' :
For Each Cel In Plg.Cells
' Pour la cellule 'Cel' (= la cellule en cours de traitement), on vérifie
'qu'elle contient une date :
If IsDate(Cel) Then
' Si oui, on relève l'année 'tmp' qui correspond à cette date :
tmp = Year(Cel.Value)
' On parcourt le tableau 'An' ...
For i = 2 To UBound(An, 2)
'... pour rechercher s'il contient la valeur de 'tmp' :
If An(1, i) = tmp Then
' Si oui, la valeur de 'i' est le rang de la colonne correspondante
'dans le tableau de données.
'
' On cherche dans cette colonne la première cellule vide.
j = 0
Do Until IsEmpty(Ref.Offset(j, i - 1)): j = j + 1: Loop
' La valeur de 'j' + 1 est le rang de la première cellule vide
'dans la colonne 'i' du tableau de données.
'
' Ligne "technique" visant à éviter des appels intempestifs de la procédure.
Application.EnableEvents = 0
' On place la valeur de 'Cel' dans la cellule vide identifiée :
Ref.Offset(j, i - 1).Value = Cel.Value
'
' ### Partie facultative qui peut être omise.
' Si on veut un tri croissant ou la suppression des doublons :
Set Col = Me.Range(Ref.Offset(0, i - 1), Ref.Offset(j, i - 1))
' Tri croissant : (Version EXCEL2007 et EXCEL2010 ; à adapter pour EXCEL2003)
On Error GoTo E
With Me.Sort
.SortFields.Clear
.SortFields.Add Key:=Col, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Col
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
E: On Error GoTo 0
' (Fin du tri)
' Suppression des doublons (NE FONCTIONNE QU'À PARTIR D'EXCEL2007) :
With Col
On Error Resume Next
.RemoveDuplicates Columns:=1, Header:=xlYes
If Err.Number = 0 Then
.Cells(1).Offset(1).Copy
.Offset(1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End If
On Error GoTo 0
End With
' (Fin de suppression des doublons)
' ### Fin de la partie facultative
'
' Ligne "technique" visant à rétablir le fonctionnement normal des appels de procédure.
Application.EnableEvents = 1
' Fermeture des boucles et des procédures conditionnelles.
Exit For
End If
Next
End If
Next
' Rétablissement de la sélection courante :
If Cible.Count = 1 And Not IsEmpty(Cible) Then Cible.Offset(1).Activate Else Cible.Activate
' Ligne "technique" : rétablissement de paramètres.
With Application: .Calculation = EtatCalc: .ScreenUpdating = 1: End With
End If
End Sub
