Paste Shape using Excel Macro

Hi All,

Sometimes need to paste couple of shapes or logo or image to other sheet using macro to another file or sheet, use below code.

Function fnpaintLogo(strSheetName,strCellNumtoPaste)

  'Sheets("Estimate Response Form").Select

  Sheets(strSheetName).Select

    Range("L1").Select

  ActiveCell.FormulaR1C1 = "C:\Users\trupti.jethva\Documentsmacros\newlogo.png"

    On Error Resume Next

    Application.ScreenUpdating = False

    ' Set to the range of cells you want to change to pictures

    Set Rng = ActiveSheet.Range("L1")

    For Each cell In Rng

        Filename = cell

        ' Use Shapes instead so that we can force it to save with the document

        Set theShape =ActiveSheet.Shapes.AddPicture( _

            Filename:=Filename, linktofile:=msoFalse, _

            savewithdocument:=msoCTrue, _

            Left:=cell.Left, Top:=cell.Top, Width:=950, Height:=950)

        If theShape Is Nothing Then GoTo isnill

        With theShape

             .Name = "Logo"

            .LockAspectRatio = msoTrue

            ' Shape position and sizes stuck to cell shape

            .Top = cell.Top + 50

            .Left = cell.Left + 50

            .Height = cell.Height + 50

            .Width = cell.Width + 50

            ' Move with the cell (and size, though that is likely buggy)

            .Placement = xlMoveAndSize

        End With

        ' Get rid of the

        cell.ClearContents

isnill:

        Set theShape = Nothing

        Range("J1").Select

    Next

    Application.ScreenUpdating = True

    Debug.Print "Done " & Now

    ActiveSheet.Shapes.Range(Array("Logo")).Select

    ActiveSheet.Shapes("Logo").PictureFormat.Brightness = 1

    Selection.Cut

    Range(strCellNumtoPaste).Select

    ActiveSheet.Paste

    Selection.ShapeRange.IncrementTop 9

    Range("A1").Select

   ' Range("L2").Clear

End Function