Macro: Inserting Pictures With Multiple Select Picture & Consecutive Placing

muhammad susanto

Well-known Member
Joined
Jan 8, 2013
Messages
2,077
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
hi expert..

this macro code below working properly to insert picture from a folder with one by one select picture
i want to modified so macro work with criteria should be:
1. can insert picture from a folder with multiple select picture and insert to multiple cell at once
2. pictures can inserted automatically consecutive/sequentially placing into target cell (target cell are random) with name of file picture are random --> (main option)
3. if point #2 impossible to do it , to insert automatically consecutive can use name of file picture or based on name pictures like e.g. photo1, photo2,photo3, photo4, or whatever name's file picture etc....> (secondary option)

VBA Code:
Sub InsertPicture()    Const cBorder As Double = 5     ' << change as required
    Dim vPicture As Variant, pic As Shape
    vPicture = Application.GetOpenFilename("Pictures (*.gif; *.jpg; *.jpeg; *.tif), *.gif; *.jpg; *.jpeg; *.tif", , "Select Picture to Import")
    If vPicture = False Then Exit Sub
   Set pic = ActiveSheet.Shapes.AddPicture(Filename:=vPicture, LinkToFile:=False, SaveWithDocument:=True, _
                Left:=ActiveCell.MergeArea.Left + cBorder, Top:=ActiveCell.MergeArea.Top + cBorder, Width:=-1, Height:=-1)
    With pic
        .LockAspectRatio = False       ' << change as required
         If Not .LockAspectRatio Then
            .Width = ActiveCell.MergeArea.Width - (2 * cBorder)
            .Height = ActiveCell.MergeArea.Height - (2 * cBorder)
        Else
            If .Width >= .Height Then
                .Width = ActiveCell.MergeArea.Width - (2 * cBorder)
            Else
                .Height = ActiveCell.MergeArea.Height - (2 * cBorder)
            End If
        End If
        .Placement = xlMoveAndSize
    End With
    Set pic = Nothing
End Sub

a cross posting VBA:Inserting Multiple Pictures With Sequence Into Multiple Cell

any help, thank you so much
susanto
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
i think how about if picture placing fix in cell C16, E16, G16, I16 with simultance at once.
Book1
ABCDEFGHI
1Nama Satuan Kerja:xx
2Lokasi:xxx
3Nomor Polisi:xxx
4Merk/Type:xxx
5Tahun Pembuatan: 2,007
6Tahun Perakitan: 2,007
7Tahun Penilaian:2021
8Warna Saat Ini:xx
9Nomor Mesin:xx
10Nomor Rangka:xx
11Isi Silinder:xx
12
13xxxxxx
14
15DataPhoto-1Photo-2Photo-3Photo-4
16aaaaaa
xxxxx
 
Upvote 0

Forum statistics

Threads
1,215,045
Messages
6,122,840
Members
449,096
Latest member
Erald

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top