CODEWITHSUNDEEP
vbaexcel
NickHallick
NickHallick

Reputation: 239

Extracting background pictures from cell comment and transferring it to another cell comment on a different sheet?

Have two sheets that I am using a Vlookup function with and it is working well except it is not bringing over the cell comment from the other sheet to the one I'm using the Vlookup on. the comment only has a background picture in it and no text. I've googled a little bit and come up with this custom Vlookup code which works when the cell has no comment but will not bring a picture/comment over when it is present

Function VlookupComment(lookval As Variant, Ftable As Range, Fcolumn As 
Long, Ftype As Long) As Variant
Application.Volatile
Dim xRet As Variant
Dim xCell As Range
xRet = Application.Match(lookval, Ftable.Columns(1), Ftype)
If IsError(xRet) Then
    VlookupComment = "Not Found"
Else
    Set xCell = Ftable.Columns(Fcolumn).Cells(1)(xRet)
    VlookupComment = xCell.Value
    With Application.Caller
        If Not .Comment Is Nothing Then
            .Comment.Delete
        End If
        If Not xCell.Comment Is Nothing Then
        xCell.Comment.Visible = True
        xCell.Comment.Shape.Select
        xCell.Comment.Shape.CopyPicture _
            Appearance:=xlScreen, Format:=xlPicture
        xCell.Comment.Visible = False

            .AddComment
            .Comment.PasteSpecial

        End If
     End With
End If

I've tried a few different things but with the same results, I'm not really familiar with VBA but have a good understanding of VB.NET so I'm just struggling with excel specific functions. Can anyone see what I need to change?

Upvotes: 1

Views: 156

Answers (1)

DecimalTurn
DecimalTurn

Reputation: 4129

To pass the picture from one comment to the other inside the same worksheet, you can use the .Pickup and .Apply methods as follow:

Function VlookupComment(lookval As Variant, Ftable As Range, _
                        Fcolumn As Long, Ftype As Long) As Variant

    Application.Volatile
    Dim xRet As Variant
    Dim xCell As Range
    xRet = Application.Match(lookval, Ftable.Columns(1), Ftype)
    If IsError(xRet) Then
        VlookupComment = "Not Found"
    Else
        Set xCell = Ftable.Columns(Fcolumn).Cells(1)(xRet)
        VlookupComment = xCell.Value
        With Application.Caller
            If Not .Comment Is Nothing Then
                .Comment.Delete
            End If
            If Not xCell.Comment Is Nothing Then
            xCell.Comment.Visible = True
            xCell.Comment.Shape.Select
            xCell.Comment.Shape.PickUp

            .AddComment
            .Comment.Shape.Apply

            End If
         End With
    End If

End Function

After reading your comment and doing some testing, it seems like the sheet where the cell whose comment is referred to must be activated to avoid the Error 70: Permission Denied.

This means that to use this formula across sheets, you'll need to activate sheets in your code, but to avoid any screen flickering, I would suggest to deactivate screenupdating before hand, like this:

Function VlookupComment(lookval As Variant, Ftable As Range, _
                        Fcolumn As Long, Ftype As Long) As Variant

    Application.Volatile
    Dim xRet As Variant
    Dim xCell As Range
    xRet = Application.Match(lookval, Ftable.Columns(1), Ftype)
    If IsError(xRet) Then
        VlookupComment = "Not Found"
    Else
        Set xCell = Ftable.Columns(Fcolumn).Cells(1)(xRet)
        VlookupComment = xCell.Value
        With Application.Caller
            If Not .Comment Is Nothing Then
                .Comment.Delete
            End If
            If Not xCell.Comment Is Nothing Then
            xCell.Comment.Visible = True
            'xCell.Comment.Shape.Select

            Application.ScreenUpdating = False
                xCell.Parent.Activate
                xCell.Comment.Shape.PickUp

                .Parent.Activate
                .AddComment
                .Comment.Shape.Apply
            Application.ScreenUpdating = True

            End If
         End With
    End If

End Function

Hopefully, the activation of sheets won't slow down the function execution too much.

Upvotes: 2

Related Questions