'---------------------------------------------------------------------------------------
' Auteur : Didier FOURGEOT (myDearFriend!)
' Date : 18/09/2005
' Sujet : MFC multiples
'---------------------------------------------------------------------------------------
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Cel As Range
Dim TabTemp As Variant
Dim L As Long
Dim V As Variant
Dim Plage_T As String
On Error Resume Next
Plage_T = Target.Dependents.Address(0, 0)
If Err.Number <> 0 Then
If Err.Number = 1004 Then
Plage_T = Target.Address(0, 0)
Else
GoTo Fin
End If
Else
Plage_T = Union(Target, Target.Dependents).Address(0, 0)
End If
On Error GoTo Fin
For Each Cel In Range(Plage_T)
If Cel.FormatConditions.Count < 1 Then Exit Sub
If Cel.FormatConditions(1).Formula1 = "=mDF" Then
With Sheets("MFC")
L = .Range("A65536").End(xlUp).Row
TabTemp = .Range(.Cells(1, 1), .Cells(L, 1)).Value
If Cel.Value = "" Then
L = 1
Else
For L = 2 To UBound(TabTemp, 1)
If Cel.Value = TabTemp(L, 1) Then Exit For
Next L
End If
On Error GoTo Fin
Application.EnableEvents = False
.Cells(L, 2).Copy
V = Cel.Formula
Cel.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Cel.Formula = V
If Cel.FormatConditions.Count < 1 Then Cel.FormatConditions.Add Type:=xlExpression, Formula1:="=mDF"
Application.CutCopyMode = False
Application.EnableEvents = True
End With
End If
Next Cel
Exit Sub
Fin:
MsgBox "Erreur non gérée dans la procédure Workbook.SheetChange()" & vbLf & "Erreur : " & _
Err & " " & Err.Description, vbOKOnly, "myDearFriend!"
Application.EnableEvents = True
End Sub