Sub InsertChemicalStructures() Dim mainWorkBook As Workbook Dim fldrDlg As FileDialog Dim chemName As String Dim fso as Object Set mainWorkBook = ThisWorkbook Rem - retreive the structure files folder Set fldrDlg = Application.FileDialog(msoFileDialogFolderPicker) fldrDlg.Title = "Select Folder Containing Structure Images" If (fldrDlg.Show <> -1) Then Exit Sub Rem - retrieve selected folder folderPath = fldrDlg.SelectedItems(1) Set fldrDlg = Nothing Set fso = CreateObject("Scripting.FileSystemObject") NoOfFiles = fso.GetFolder(folderPath).Files.Count Set listfiles = fso.GetFolder(folderPath).Files For Each fls In listfiles strCompFilePath = folderPath & "\" & Trim(fls.Name) If strCompFilePath <> "" Then If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _ Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _ Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1 _ Or InStr(1, strCompFilePath, "emf", vbTextCompare) > 1) Then chemName = Left(fls.Name, InStrRev(fls.Name, ".") - 1) counter = counter + 1 ActiveSheet.Range("A" & counter).Value = chemName ActiveSheet.Range("B" & counter).ColumnWidth = 100 ActiveSheet.Range("B" & counter).RowHeight = 60 ActiveSheet.Range("B" & counter).Activate Call insert(strCompFilePath, counter) ActiveSheet.Activate End If End If Next End Sub Function insert(PicPath, counter) Dim pict As Shape Rem - Add the picture to the current sheet Set pict = Application.ActiveSheet.Shapes.AddPicture(PicPath, msoTrue, msoFalse, 0, 0, -1, -1) Rem - Specify picture attributes pict.LockAspectRatio = msoTrue pict.Height = 80 Rem - Position picture in cell pict.Left = ActiveSheet.Range("B" & counter).Left + 2 pict.Top = ActiveSheet.Range("B" & counter).Top + 2 pict.Placement = xlMove End Function