'### Eventuellement, adapter les constantes ###
Const MA_SOURCE As String = "\[Dépenses (source).xls]Fonctionnement'!"
Const MA_PLAGE As String = "G5:R5"
Const INCREMENT As Long = 4
'##############################################
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim R As Range
Dim R2 As Range
Dim C As Range
Dim CM As Comment
Dim A$
Dim var
Dim lastLig&
Dim i&
Set R = Range(MA_PLAGE)
lastLig& = ActiveSheet.[f65536].End(xlUp).Row
If lastLig& > INCREMENT * 2 Then Set R2 = R
For i& = Range(MA_PLAGE).Row + INCREMENT To lastLig& Step INCREMENT
Set R2 = R2.Offset(INCREMENT, 0)
Set R = Application.Union(R, R2)
Next i&
For Each C In R
On Error Resume Next
C.Comment.Delete
Next C
Err.Clear
Set R2 = Range(Target.Address)
If Application.Intersect(R, R2) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
If R2 <> "" Then
On Error GoTo Erreur
A$ = "'" & ThisWorkbook.Path & MA_SOURCE & _
R2.Offset(-2, 0).Address(ReferenceStyle:=xlR1C1)
var = ExecuteExcel4Macro(A$)
If var <> "" And IsNumeric(var) Then
Set CM = R2.AddComment
CM.Visible = True
CM.Text Text:=Format(var, "# ### ### ##0.00")
End If
CM.Shape.Select True
With Selection
With .Font
.Name = "Arial"
.FontStyle = "Gras"
.Size = 10
.ColorIndex = 5
End With
.AutoSize = True
.ShapeRange.Fill.ForeColor.SchemeColor = 41
.Placement = xlMove
.PrintObject = True
End With
R2.Select
End If
Erreur:
Application.ScreenUpdating = True
If Err = 1004 Then
MsgBox prompt:="Erreur 1004" & vbCrLf & vbCrLf & _
"Le chemin ci-dessous contient au moins une apostrophe :" & _
vbCrLf & ThisWorkbook.Path & vbCrLf & vbCrLf & _
"Veuillez le(s) retirer.", Buttons:=vbCritical, _
Title:="Programme stoppé - Apostrophe interdite dans le chemin"
ElseIf Err <> 0 Then
MsgBox Err.Number & vbCrLf & Err.Description
End If
End Sub