Inserting Picture & Autofit Can Work on Single & Merged Cell

[muhammad susanto]

hi expert..
i found code to Inserting picture in a cell (autofit), but this code work in single cell..
i want this code working on single cell and merged cell
here this code (how to modify it)

Sub InsertPicture()
Dim sPicture As String, pic As Picture

sPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")

If sPicture = "False" Then Exit Sub

Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = ActiveCell.Height
.Width = ActiveCell.Width
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMoveAndSize
End With

Set pic = Nothing

End Sub

anyone help me, thank very much
.sst

 

[JoeMo]

Hi muhammad. This is untested, but give it a try:

With Pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = ActiveCell.MergeArea.Height
.Width = ActiveCell.MergeArea.Width
.Top = ActiveCell.MergeArea.Top
.Left = ActiveCell.MergeArea.Left
.Placement = xlMoveAndSize
End With

 

[muhammad susanto]

Hi muhammad. This is untested, but give it a try:

With Pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = ActiveCell.MergeArea.Height
.Width = ActiveCell.MergeArea.Width
.Top = ActiveCell.MergeArea.Top
.Left = ActiveCell.MergeArea.Left
.Placement = xlMoveAndSize
End With

hi JoeMo,,,,
wowwwww...very fast like F1,...
Worked well. Perfecto...
thank you so much!!!!

 

[JoeMo]

hi JoeMo,,,,
wowwwww...very fast like F1,...
Worked well. Perfecto...
thank you so much!!!!

You are welcome - thanks for the reply.