Moving Excel pictures from the cell to the comment area

[kenner99]

I have an excel spreadsheet with hundreds of rows, each containing one cell with a picture. The picture is small. I'd like to make it larger, without having to make the cell larger. So, I want to move it to a comment within the cell, where it can be displayed much larger, whenever the user hovers over the comment indicator.

The problem is moving it. I do not have these pictures stored anywhere else besides the spreadsheet. When inserting pictures into the comments area, excel asks for the location of the picture, expecting that it is in a directory. And getting the picture from a cell in Excel to a directory is not easy, since it can't be copied and pasted. It has to first be copied to another application, and then saved.

So...my question is...is there a simple way to move the picture from inside the cell, to a comment in the cell instead.

Thanks so much for any help

 

[Worf]

Welcome to the Board

Please test this on a copy of your workbook:

Sub Kenner()
Dim ch As ChartObject, wdt!, ht!, ws As Worksheet, i%
Dim cmt As Comment, cp$, rng As Range, sh As Picture
Set ws = ActiveSheet
For i = ws.Pictures.Count To 1 Step -1
    Set sh = ws.Pictures(i)
    Set rng = sh.TopLeftCell
    cp = ThisWorkbook.path & "\" & "Pic_" & Format(Date, "yyyymmdd") & i & ".gif"
    wdt = sh.Width
    ht = sh.Height
    sh.Cut
    Set ch = ws.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, Width:=wdt, Height:=ht)
    ch.Chart.Paste
    rng.Activate
    ch.Chart.Export cp
    ch.Delete
    Set cmt = rng.AddComment
    cmt.Text Text:=""
    With cmt.Shape
      .Fill.UserPicture cp
      .Width = wdt
      .Height = ht
    End With
Next
End Sub

 

[kenner99]

Welcome to the Board

Please test this on a copy of your workbook:

Sub Kenner()
Dim ch As ChartObject, wdt!, ht!, ws As Worksheet, i%
Dim cmt As Comment, cp$, rng As Range, sh As Picture
Set ws = ActiveSheet
For i = ws.Pictures.Count To 1 Step -1
    Set sh = ws.Pictures(i)
    Set rng = sh.TopLeftCell
    cp = ThisWorkbook.path & "\" & "Pic_" & Format(Date, "yyyymmdd") & i & ".gif"
    wdt = sh.Width
    ht = sh.Height
    sh.Cut
    Set ch = ws.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top, Width:=wdt, Height:=ht)
    ch.Chart.Paste
    rng.Activate
    ch.Chart.Export cp
    ch.Delete
    Set cmt = rng.AddComment
    cmt.Text Text:=""
    With cmt.Shape
      .Fill.UserPicture cp
      .Width = wdt
      .Height = ht
    End With
Next
End Sub

Thanks Worf. Unfortunately, it's been many years since I did coding. I'm embarrassed to admit I don't know where to start to use this code. My friend who has the issue has solved it in another way. But thanks so much for your efforts.

 

[Worf]

How to use the code:

- At Excel, press alt+f11
- Click insert>module
- Paste the code
- Press alt+f11 to return to Excel
- Activate the desired sheet
- Press alt+f8 to bring up the macro dialog box
- Choose the desired macro and run it

 

[kenner99]

How to use the code:

- At Excel, press alt+f11
- Click insert>module
- Paste the code
- Press alt+f11 to return to Excel
- Activate the desired sheet
- Press alt+f8 to bring up the macro dialog box
- Choose the desired macro and run it

Wow. That was easy. Thanks so much. It works!