VBA- Copy cell range to comments as picture

[Mikeyb168]

Hi I have the following code which copy's a selected cell range to a selected cell as a picture and inserts it as a cell comment as a picture on another tab. It functions ok, except when I have another existing chart (graph) already on the page. The ChartObject at the final deletion step deletes my other graph I have on the page. Need some help fixing it.

Public Sub CommentV1()
'
' Macro1 Macro
'
Dim TempCht2 As Chart
Dim Rng As Range, w, h
Dim fname As String
Set Rng = Worksheets("Test pivot").Range("N65:Q80")
Rng.CopyPicture
  w = Rng.Width
  h = Rng.Height
    ActiveSheet.ChartObjects.Add Left:=200, Top:=50, Width:=w, Height:=h
    ActiveSheet.ChartObjects(1).Activate
    ActiveChart.Paste
    fname = ThisWorkbook.Path & "\temp2.gif"
    'MsgBox fname
    ActiveChart.Export Filename:=fname, Filtername:="Gif"
With Range("m13")
        On Error Resume Next
            .Comment.Delete
        On Error GoTo 0
            .AddComment
            .Comment.Shape.Fill.UserPicture fname
            .Comment.Shape.Width = w
            .Comment.Shape.Height = h
End With
ActiveSheet.ChartObjects(1).Delete

End Sub

 

[vletm]

Mikeyb168
First You'll activate always 1st ChartObject
ActiveSheet.ChartObjects(1).Activate
... that (1) should be something else especially if there is/are other ChartObject(s).
eg ActiveChart.Name = "Name of this Chart"
In the end - You'll always delete the 1st ChartObject ... then You'll loose it always.
ActiveSheet.ChartObjects(1).Delete
... You should delete that named Chart

 

[Debaser]

I'd use the object variable:

Public Sub CommentV1()
'
' Macro1 Macro
'
Dim TempCht2 As Chart
Dim Rng As Range, w, h
Dim fname As String
Set Rng = Worksheets("Test pivot").Range("N65:Q80")
Rng.CopyPicture
  w = Rng.Width
  h = Rng.Height
    Set TempCht2 = ActiveSheet.ChartObjects.Add(Left:=200, Top:=50, Width:=w, Height:=h).Chart
   With TempCht2
      .Parent.Activate
      .Paste
    fname = ThisWorkbook.Path & "\temp2.gif"
    'MsgBox fname
    .Export Filename:=fname, Filtername:="Gif"
    End With
With Range("m13")
        On Error Resume Next
            .Comment.Delete
        On Error GoTo 0
            .AddComment
            .Comment.Shape.Fill.UserPicture fname
            .Comment.Shape.Width = w
            .Comment.Shape.Height = h
End With
TempCht2.Parent.Delete

End Sub

 

[Mikeyb168]

Thanks Debaser, tested it last week and works perfectly.