Сделать такую штутку мне пришло в голову случайно, когда это понадобилось кому-то на одном из форумов, на которых я общаюсь. Вот и решил — если это нужно кому-то одному, то может понадобится и другим. Изначально макрос копирования картинки из примечания появился в надстройке MyAddin — Копирование картинки из примечания. Теперь решил поделиться кодом в этой статье, т.к. возможно это поможет кому-то в решении подобной проблемы. Что делает код ниже? Он копирует каритнки из примечаний в выделенных ячейках. Т.е. сначала Вы выделяете одну или несколько ячеек, а затем запускаете код. Вот и все. После этого в ячейке, расположенной правее ячейки с примечанияем будет картинка этого примечания.

Sub Copy_Picture_From_comment()
    If TypeName(Selection) <> "Range" Then MsgBox "Выделенная область не является диапазоном!", vbCritical, "Ошибка": Exit Sub
    Dim rRange As Range, rCell As Range, oComment As Comment
    Dim bVisible As Boolean
 
    On Error Resume Next
    Set rRange = Selection.SpecialCells(xlCellTypeComments)
    If rRange Is Nothing Then Exit Sub
    Application.ScreenUpdating = 0
 
    For Each rCell In rRange
        Set oComment = rCell.Comment
        If Not oComment Is Nothing Then
            bVisible = oComment.Visible
            With rCell
                .Comment.Visible = True
                .Comment.Shape.CopyPicture xlScreen, xlBitmap
                .Offset(, 1).PasteSpecial
                .Comment.Visible = bVisible
            End With
        End If
    Next rCell
    Application.ScreenUpdating = 1
    Set rRange = Nothing: Set rCell = Nothing: Set oComment = Nothing
 
End Sub

Sub Copy_Picture_From_comment()
    If TypeName(Selection) <> "Range" Then MsgBox "Выделенная область не является диапазоном!", vbCritical, "Ошибка": Exit Sub
    Dim rRange As Range, rCell As Range, oComment As Comment
    Dim bVisible As Boolean

    On Error Resume Next
    Set rRange = Selection.SpecialCells(xlCellTypeComments)
    If rRange Is Nothing Then Exit Sub
    Application.ScreenUpdating = 0

    For Each rCell In rRange
        Set oComment = rCell.Comment
        If Not oComment Is Nothing Then
            bVisible = oComment.Visible
            With rCell
                .Comment.Visible = True
                .Comment.Shape.CopyPicture xlScreen, xlBitmap
                .Offset(, 1).PasteSpecial
                .Comment.Visible = bVisible
            End With
        End If
    Next rCell
    Application.ScreenUpdating = 1
    Set rRange = Nothing: Set rCell = Nothing: Set oComment = Nothing

End Sub

Если вдруг Вам данные картинки надо сохранить не на лист Excel, а на диск, то Вы можете сначала применить код выше, а затем код, выложенный в этой статье для сохранения на диск. Ну а тем, кто хоть немного разбирается в кодах, не составит труда при необходимости совместить коды из этих двух статей в один единый.

Скачать пример »