Bonjour,
Je trouve le code vraiment bien fait. j'imagine même pas le temps pour faire les commentaires sans celle-ci
A mon niveau, j'ai simplement suspendu (durant la macro) les mises à jour de calcul et d'affichage. Sur la plage active, on passe de 36 sec à 24 sec
Je ne sais pas si un tiers du temps c'est "considérable" ? Il y a peut-être d'autres améliorations possibles, mais je ne les maitrise pas
Sub Commentairedynamique()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("VB")
For Each cell In ws.Range("M2:R10")
If cell.Value <> "---" Then
annee = ws.Cells(1, cell.Column).Value
produit = ws.Cells(cell.Row, "L").Value
If IsNumeric(annee) Then
If Not cell.Comment Is Nothing Then
cell.Comment.Delete
End If
Set dictClients = CreateObject("Scripting.Dictionary")
For i = 2 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If ws.Cells(i, "C").Value = annee And ws.Cells(i, "F").Value = produit Then
client = ws.Cells(i, "D").Value
If dictClients.Exists(client) Then
dictClients(client) = dictClients(client) + ws.Cells(i, "H").Value
Else
dictClients(client) = ws.Cells(i, "H").Value
End If
End If
Next i
ReDim keyValuePairs(0 To dictClients.Count - 1, 0 To 1)
i = 0
For Each client In dictClients.Keys
keyValuePairs(i, 0) = client
keyValuePairs(i, 1) = dictClients(client)
i = i + 1
Next client
For i = LBound(keyValuePairs, 1) To UBound(keyValuePairs, 1) - 1
For j = i + 1 To UBound(keyValuePairs, 1)
If keyValuePairs(i, 1) < keyValuePairs(j, 1) Then
tempClient = keyValuePairs(i, 0)
tempQuantite = keyValuePairs(i, 1)
keyValuePairs(i, 0) = keyValuePairs(j, 0)
keyValuePairs(i, 1) = keyValuePairs(j, 1)
keyValuePairs(j, 0) = tempClient
keyValuePairs(j, 1) = tempQuantite
End If
Next j
Next i
commentaire = ""
For i = LBound(keyValuePairs, 1) To UBound(keyValuePairs, 1)
commentaire = commentaire & IIf(commentaire = "", "", vbCrLf) & keyValuePairs(i, 0) & " : " & keyValuePairs(i, 1)
Next i
If commentaire <> "" Then
cell.AddComment commentaire
With cell.Comment.Shape.TextFrame
.AutoSize = True
.Characters.Font.Name = "Calibri"
.Characters.Font.Size = 11
.Characters.Font.Color = RGB(255, 255, 255)
.Characters.Font.Bold = True
End With
cell.Comment.Shape.Fill.ForeColor.RGB = RGB(0, 50, 100)
cell.Comment.Visible = False
End If
End If
End If
Set dictClients = Nothing
Next cell
Set ws = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Tu copies/colles le code en lieu et place dans ton module.
Leakim