VBA : Insert Pictures in Multiple Worksheet At Once

[muhammad susanto]

hi expert....

this code work properly only for 3 pictures to inserted into 3 cells, but i want to modify how this code below work in n pictures (multiple pictures) then inserted only in cell H10 for each sheet..

Sub InsertPic()    
    Dim I As Long
    Dim xPath As String
    Dim xShape As Shape
    Dim xRg As Range
    
    Dim xFiles
    Dim j   As Long
    Dim a   As Range
    
    xPath = "L:\test\"
    xFiles = Array("1.jpg", "2.jpg", "3.jpg")
    
    If Dir(xPath & "*.jpg") = "" Then
        MsgBox "Picture file was not found in path!", vbInformation, "test"
        Exit Sub
    End If
    
    For I = 1 To ActiveWorkbook.Sheets.Count
        Set xRg = Sheets(I).Range("B10:C10,D10:E10,f10:g10")
        For j = 1 To xRg.Areas.Count
            Set a = xRg.Areas(j)
            Set xShape = Sheets(I).Shapes.AddPicture(xPath & xFiles(j - 1), True, True, a.Left, a.Top, a.Width, a.Height)
        Next
    Next


End Sub

expected result :
example :
1.jpg----inserted in SheetA--cell H10
2.jpg----inserted in SheetB--cell H10
3.jpg----inserted in SheetC--cell H10
100.jpg---inserted in SheetXX--cell H10
etc...

.sst

 

[MickG]

Based on your Code, Try this:-
NB:- Change ColumnWidth/RowHeight in Code to suit.

[COLOR="Navy"]Sub[/COLOR] InsertPic()        
    [COLOR="Navy"]Dim[/COLOR] I [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
    [COLOR="Navy"]Dim[/COLOR] xPath [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
    [COLOR="Navy"]Dim[/COLOR] xShape [COLOR="Navy"]As[/COLOR] Shape
    [COLOR="Navy"]Dim[/COLOR] a  [COLOR="Navy"]As[/COLOR] Range
    
    xPath = "L:\test\"
    
    [COLOR="Navy"]If[/COLOR] Dir(xPath & "*.jpg") = "" [COLOR="Navy"]Then[/COLOR]
        MsgBox "Picture file was not found in path!", vbInformation, "test"
        [COLOR="Navy"]Exit[/COLOR] [COLOR="Navy"]Sub[/COLOR]
    [COLOR="Navy"]End[/COLOR] If
    
    [COLOR="Navy"]For[/COLOR] I = 1 To ActiveWorkbook.Sheets.Count
        [COLOR="Navy"]Set[/COLOR] a = Sheets(I).Range("H10")
            a.RowHeight = 100
            a.ColumnWidth = 20
            [COLOR="Navy"]Set[/COLOR] xShape = Sheets(I).Shapes.AddPicture(xPath & I & ".jpg", True, True, a.Left, a.Top, a.Width, a.Height)
    [COLOR="Navy"]Next[/COLOR]

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[muhammad susanto]

hi MickG...1000% working well...
thank you, you really kindman...

 

[MickG]

You're welcome