Selva’s Site

Option Explicit
'       Written by Selva V Pasupathy
'       You are free to use the code and make changes
'       contact me at selvavinaygam (at) GMail (dot) com
Dim j               As Long
Dim k               As Long
Dim lRow         As Long
Dim lCol                  As Long
Dim cFormula      As Range
Dim rFormula      As Range
Dim cValue        As Range
Dim rValue        As Range
Dim myShape             As Shape
Dim mySheet              As Worksheet

Sub ExcelDiet()
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 For Each mySheet In Worksheets
   With mySheet
    On Error Resume Next
    Set cFormula = .Cells.Find(What:="*", _
            After:=Range("A1"), LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious)
    Set cValue = .Cells.Find(What:="*", _
            After:=Range("A1"), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByColumns, _
            SearchDirection:=xlPrevious)
    Set rFormula = .Cells.Find(What:="*", _
            After:=Range("A1"), LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRomySheet, _
            SearchDirection:=xlPrevious)
    Set rValue = .Cells.Find(What:="*", _
            After:=Range("A1"), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRomySheet, _
            SearchDirection:=xlPrevious)
    On Error GoTo 0
    If cFormula Is Nothing Then
        lCol = 0
    Else
        lCol = cFormula.Column
    End If
    If Not cValue Is Nothing Then
        lCol = Application.WorksheetFunction. _
                Max(lCol, cValue.Column)
    End If
    If rFormula Is Nothing Then
        lRow = 0
    Else
        lRow = rFormula.Row
    End If
    If Not rValue Is Nothing Then
        lRow = Application.WorksheetFunction. _
                Max(lRow, rValue.Row)
    End If
    For Each myShape In .Shapes
        j = 0
        k = 0
        On Error Resume Next
        j = myShape.TopLeftCell.Row
        k = myShape.TopLeftCell.Column
        On Error GoTo 0
        If j > 0 And k > 0 Then
            Do Until .Cells(j, k).Top > _
                    myShape.Top + myShape.Height
                j = j + 1
            Loop
            If j > lRow Then
                lRow = j
            End If
            Do Until .Cells(j, k).Left > _
                    myShape.Left + myShape.Width
                k = k + 1
            Loop
            If k > lCol Then
                lCol = k
            End If
        End If
    Next
    .Range(Cells(1, lCol + 1).Address & ":IV65536").Delete
    .Range(Cells(lRow + 1, 1).Address & ":IV65536").Delete
   End With
 Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Option Explicit

Const ImgFileFormat = "Image Files (*.bmp;*.gif;*.tif;*.jpg;*.jpeg)," & _
    "*bmp;*gif;*.tif;*.jpg;*.jpeg"

Sub AddPicturesToComments()
Dim HasCom
Dim Pict As String
Dim Ans As Integer

Set HasCom = ActiveCell.Comment
If Not HasCom Is Nothing Then ActiveCell.Comment.Delete
Set HasCom = Nothing

GetPict:
Pict = Application.GetOpenFilename(ImgFileFormat)
'Note you can load in, almost any file format
If Pict = "False" Then End

Ans = MsgBox("Open : " & Pict, vbYesNo + vbExclamation, "Use this Picture?")
If Ans = vbNo Then GoTo GetPict

With ActiveCell
    .AddComment
    .Comment.Visible = False
    .Comment.Shape.Fill.Transparency = 0#
    .Comment.Shape.Fill.UserPicture Pict
End With

End Sub