I have the following code
Code: Select all
Sub Test()
Dim picList(), picFormat As String, rng As Range, sShape As Shape, xColIndex As Integer, xRowIndex As Integer, lLoop As Integer
On Error Resume Next
picList = Application.GetOpenFilename(picFormat, MultiSelect:=True)
xRowIndex = 1 'Row Number
xColIndex = 2 'Column Number
Application.ScreenUpdating = False
If IsArray(picList) Then
For lLoop = LBound(picList) To UBound(picList)
Set rng = Cells(xRowIndex, xColIndex)
Set sShape = ActiveSheet.Shapes.AddPicture(picList(lLoop), msoFalse, msoCTrue, rng.Left, rng.Top, rng.Width, rng.Height)
rng.Offset(, -1).Value = Split(Split(picList(lLoop), "\")(UBound(Split(picList(lLoop), "\"))), ".")(0)
xRowIndex = xRowIndex + 1
Next lLoop
End If
Application.ScreenUpdating = True
End Sub