XL 2016 macro exectutable si valeur cellule

[jeromeN95]

Bonjour à toutes et à tous,
Tout d'abord meilleur voeux !

J'ai ce code qui ralentie considérablement mon classeur :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If D2 Then
If Not IsNumeric(Sh.Name) Then Exit Sub
Dim c As Range, S As Shape
Application.ScreenUpdating = False
On Error Resume Next
For Each c In Sh.[K:K].SpecialCells(xlCellTypeFormulas)
    Set S = Nothing
    Set S = Sheets("Base").Shapes(c)
    If Not S Is Nothing Then
        c(1, 0).Select
        S.CopyPicture
        Sh.Paste
        Selection.ShapeRange.LockAspectRatio = msoFalse
        Selection.Width = c(1, 0).Width
        Selection.Height = c(1, 0).Height
    End If
Next
Application.GoTo Sh.[A1], True 'cadrage
ActiveCell.Copy ActiveCell 'vide le presse-papiers
End If
End Sub

Je souhaiterai qu'il ne s'execute que lorsque la valeur de la cellule D2 change.

Pourriez vous m'aider svp?

 

[Phil69970]

Bonjour Jérôme, le forum

Je te propose ceci qui devrait correspondre à tes attentes

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'If D2 Then

If Not Application.Intersect(Target, Range("D2")) Is Nothing Then

    If Not IsNumeric(Sh.Name) Then Exit Sub
    Dim c As Range, S As Shape
    Application.ScreenUpdating = False
    On Error Resume Next

        For Each c In Sh.[K:K].SpecialCells(xlCellTypeFormulas)
            Set S = Nothing
            Set S = Sheets("Base").Shapes(c)
            If Not S Is Nothing Then
                c(1, 0).Select
                S.CopyPicture
                Sh.Paste
                Selection.ShapeRange.LockAspectRatio = msoFalse
                Selection.Width = c(1, 0).Width
                Selection.Height = c(1, 0).Height
            End If
        Next

    Application.GoTo Sh.[A1], True 'cadrage
    ActiveCell.Copy ActiveCell 'vide le presse-papiers
End If
End Sub

*Code légèrement modifié à 11h57
@Phil69970

 

[jeromeN95]

Bonjour

Phil69970​

Je te remercie pour ta réactivité.

Ta proposition semble améliorer la rapidité de fonctionnement de mon classeur.
Néanmoins il reste lent.
Je pense, de ce fait, qu'il s'agit plutôt des nombreuses photos formule.
En effet, je fonctionne avec des images (appareil photo) en fonction du résultat en D2...

Je vais essayer de fonctionner différemment.

MERCI beaucoup.

 

[soan]

Bonjour Phil, Jérôme,

comme il s'agit de la seule cellule D2, je propose :

If Target.Address <> "$D$2" Then Exit Sub

(donc sans utiliser .Intersect)

soan

 

[jeromeN95]

Bonjour Soan,
merci pour ta proposition.

Peut tu écrire le code complet stp avec If Target.Address <> "$D$2" Then Exit Sub ?
J'ai une erreur :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'If D2 Then

If Target.Address <> "$D$2" Then Exit Sub
    If Not IsNumeric(Sh.Name) Then Exit Sub
    Dim c As Range, S As Shape
    Application.ScreenUpdating = False
    On Error Resume Next

        For Each c In Sh.[K:K].SpecialCells(xlCellTypeFormulas)
            Set S = Nothing
            Set S = Sheets("Base").Shapes(c)
            If Not S Is Nothing Then
                c(1, 0).Select
                S.CopyPicture
                Sh.Paste
                Selection.ShapeRange.LockAspectRatio = msoFalse
                Selection.Width = c(1, 0).Width
                Selection.Height = c(1, 0).Height
            End If
        Next

    Application.GoTo Sh.[A1], True 'cadrage
    ActiveCell.Copy ActiveCell 'vide le presse-papiers
End If
End Sub

 

[soan]

@jeromeN95

tu as juste oublié d'enlever le End If qui est juste au-dessus du End Sub

ça donne ceci (avec une ré-indentation correcte du code VBA) :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Address <> "$D$2" Then Exit Sub
  If Not IsNumeric(Sh.Name) Then Exit Sub
  Dim c As Range, S As Shape
  Application.ScreenUpdating = False
  On Error Resume Next

  For Each c In Sh.[K:K].SpecialCells(xlCellTypeFormulas)
    Set S = Nothing
    Set S = Sheets("Base").Shapes(c)
    If Not S Is Nothing Then
      c(1, 0).Select
      S.CopyPicture
      Sh.Paste
      Selection.ShapeRange.LockAspectRatio = msoFalse
      Selection.Width = c(1, 0).Width
      Selection.Height = c(1, 0).Height
    End If
  Next c

  Application.GoTo Sh.[A1], True 'cadrage
  ActiveCell.Copy ActiveCell 'vide le presse-papiers
End Sub

(j'ai testé la compilation : c'est ok)

soan

 

[Staple1600]

Bonjour le fil

[moment Recyclerie]
Une autre façon de faire
(recyclée d'une réponse que j'ai posté mai 2019 dans un autre fil)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range
If Not Application.Intersect(Target, Range("D2")) Is Nothing Then
Application.ScreenUpdating = False
On Error Resume Next
For Each c In Me.[K:K].SpecialCells(-4123)
c(1, 0).Select: CopierShape Sheets("Base"), Me, c.Value
With Selection: .ShapeRange.LockAspectRatio = 0: .Width = c(1, 0).Width: .Height = c(1, 0).Height: End With
Next
Application.GoTo [A1], True 'cadrage
ActiveCell.Copy ActiveCell 'vide le presse-papiers
End If
End Sub
Private Sub CopierShape(ws1 As Worksheet, ws2 As Worksheet, shpIdx&)
Dim shp As Shape
Set shp = ws1.Shapes(shpIdx).Duplicate: shp.Cut: ws2.Paste
End Sub

Test OK sur Excel 2013 (et sur mon fichier de test)
[/moment Recyclerie]

 

[jeromeN95]

Bonjour Staple,
qu'es ce que :
"
Private Sub CopierShape(ws1 As Worksheet, ws2 As Worksheet, shpIdx&)
Dim shp As Shape
Set shp = ws1.Shapes(shpIdx).Duplicate: shp.Cut: ws2.Paste
End Sub
" ?

Avantage ?

 

[soan]

@jeromeN95

je crois que tu as zappé mon post #6.

soan

 

[Staple1600]

Bonjour jeromeN95 (et meilleurs vœux pour 2021)

C'est une fonction personnalisée.
Et comme je l'ai écrit en préambule: "Une autre façon de faire"
L'avantage premier c'est de varier les plaisirs et de nourrir la curiosité des utilisateurs de VBA.

NB: [avis personnel]
Pour moi une question n'est jamais résolue.
En VBA, il y a N façons de faire une tâche donnée.
Donc je publie une façon de faire si je vois qu'elle n'a pas été publiée précédemment.
Et accessoirement cela occupe mon dimanche après-midi.
[/avis personnel]