Insert Pictures From Multiple Sheet to a Sheet in Any Cell Then Autofit Resize

[muhammad susanto]

hi expert..

this code below working well to insert picture then automatic resize in a cell but unfortunally this code only work in the same sheet
i want to make how this code work between several/multiple sheet..
here this code :

Public Sub FitPic()
On Error GoTo NOT_SHAPE
Dim PicWtoHRatio As Single
Dim CellWtoHRatio As Single
With Selection
PicWtoHRatio = .Width / .Height
End With
With Selection.TopLeftCell
CellWtoHRatio = .Width / .RowHeight
End With
Select Case PicWtoHRatio / CellWtoHRatio
Case Is > 1
With Selection
.Width = .TopLeftCell.Width
.Height = .Width / PicWtoHRatio
End With
Case Else
With Selection
.Height = .TopLeftCell.RowHeight
.Width = .Height * PicWtoHRatio
End With
End Select
With Selection
.Top = .TopLeftCell.Top
.Left = .TopLeftCell.Left
End With
Exit Sub
NOT_SHAPE:
MsgBox "Select a picture before running this macro."
End Sub

i want can select picture from another sheet before running this macro between sheet
my target in sheet bm1, bm2, etc..in any cell.....and then my photos from sheet p1,p2,p3, p...etc....(the name sheet is random)

this my link file Box

any help, greatly appreciated..

.sst

 

[Yongle]

Select picture (as before) before running macro

When input box appears ...
click on target sheet tab
click on target cell
click OK

Public Sub FitPic()
On Error GoTo NOT_SHAPE
    Dim PicWtoHRatio As Single
    Dim CellWtoHRatio As Single
    Dim cel As Range
    Selection.Cut
    Set cel = Application.InputBox("Click on destination tab and cell", "", , , , , , 8)
    With cel
        .Parent.Activate
        .Activate
        .Parent.Paste
    End With
   
    With Selection
        PicWtoHRatio = .Width / .Height
    End With
    With cel
        CellWtoHRatio = .Width / .RowHeight
    End With
    Select Case PicWtoHRatio / CellWtoHRatio
        Case Is > 1
            With Selection
            .Width = cel.Width
            .Height = .Width / PicWtoHRatio
            End With
        Case Else
            With Selection
            .Height = cel.RowHeight
            .Width = .Height * PicWtoHRatio
            End With
    End Select
    With Selection
        .Top = cel.Top
        .Left = cel.Left
    End With
Exit Sub
NOT_SHAPE:
MsgBox "Select a picture before running this macro."
End Sub

The above code MOVES the picture 

To COPY... replace
Selection.Cut
with
Selection.Copy

 

[muhammad susanto]

hi Yongle...thank you so much..
working 100%, GREAT!!!

 

[muhammad susanto]

hi Yongle .

for easy & simple step, would you, to modify your code so your step can be change, like this :
1. click on sheet tab/target cell;
2. then select target picture from another sheet to be copy (as before) before running macro;
3. click OK (finish)

 

[muhammad susanto]

Select picture (as before) before running macro

When input box appears ...
click on target sheet tab
click on target cell
click OK

Public Sub FitPic()
On Error GoTo NOT_SHAPE
    Dim PicWtoHRatio As Single
    Dim CellWtoHRatio As Single
    Dim cel As Range
    Selection.Cut
    Set cel = Application.InputBox("Click on destination tab and cell", "", , , , , , 8)
    With cel
        .Parent.Activate
        .Activate
        .Parent.Paste
    End With
 
    With Selection
        PicWtoHRatio = .Width / .Height
    End With
    With cel
        CellWtoHRatio = .Width / .RowHeight
    End With
    Select Case PicWtoHRatio / CellWtoHRatio
        Case Is > 1
            With Selection
            .Width = cel.Width
            .Height = .Width / PicWtoHRatio
            End With
        Case Else
            With Selection
            .Height = cel.RowHeight
            .Width = .Height * PicWtoHRatio
            End With
    End Select
    With Selection
        .Top = cel.Top
        .Left = cel.Left
    End With
Exit Sub
NOT_SHAPE:
MsgBox "Select a picture before running this macro."
End Sub

The above code MOVES the picture 

To COPY... replace
Selection.Cut
with
Selection.Copy

hi Yongle .

for easy & simple step, would you, to modify your code so your step can be change, like this :
1. first, click on sheet tab/target cell;
2. then select target picture from another sheet to be copy (as before) before running macro;
3. click OK (finish)

 

[Yongle]

Application.InputBox method makes it easy to pause the code whilst you select the cell
That mehod is not available for shapes
I will think about it when I have some time
Check thread in 2 days

 

[muhammad susanto]

yongle...thank for your kindness.
i'm waiting you.

 

[Yongle]

VBA cannot be interrupted to select a shape
Trying to find a workaround
One way is to use 2 macros - is that ok?

 

[Yongle]

Delete previous code

1. Run PictureDestination
2. Select picture & run FitPic

In a module

Option Explicit

Public dCell As Range   'destination for picture

Sub PictureDestination()
    Set dCell = Application.InputBox("Click destination tab, click cell,click OK", "", , , , , , 8)
    MsgBox "select image and run FitPic", vbOKOnly, ""
End Sub

Sub FitPic()
'variables and constants
    Const msg1 = "Select destination before selecting picture"
    Const msg2 = "Select a picture before running this macro"
    Dim msg As String
    Dim PicWtoHRatio As Single
    Dim CellWtoHRatio As Single
    Dim PicSheet As Worksheet
'destination details
    On Error GoTo Handling
    
'move picture
    Set PicSheet = ActiveSheet
    msg = msg1
    dCell.Parent.Activate           'forces error if destination empty
    dCell.Select                    'deselects images in destination sheet
    PicSheet.Activate
    msg = msg2
    Selection.Cut
    dCell.Parent.Activate
    dCell.Parent.Paste ActiveCell
    
'resize picture
    CellWtoHRatio = ActiveCell.Width / ActiveCell.RowHeight
    With Selection
        PicWtoHRatio = .Width / .Height
    End With
    Select Case PicWtoHRatio / CellWtoHRatio
    Case Is > 1
        With Selection
            .Width = ActiveCell.Width
            .Height = .Width / PicWtoHRatio
        End With
    Case Else
        With Selection
            .Height = ActiveCell.RowHeight
            .Width = .Height * PicWtoHRatio
        End With
    End Select
    With Selection
        .Top = ActiveCell.Top
        .Left = ActiveCell.Left
    End With
    Set dCell = Nothing
Exit Sub
Handling: MsgBox msg
End Sub

 

[muhammad susanto]

hi Yongle..thank you very much!!!