Sub Insert_Picture()'take item number in Name_Column, insert corresponding picture in Picture_Column
Const Sheet_to_Insert_Picture = 1
Const Name_Column = 9 'column that holds the name of the picture file
Const Picture_Column = 1 'column that holds pictures
Dim p As Object
Dim cell_width As Double
Dim cell_height As Double
Dim factor As Double
Dim Top_Offset As Integer 'offset of picture top
Dim Last_Row As Integer 'last row in thisworkbook.sheets(sheet_to_insert_picture)
Dim rng As Range 'range of the cells to add pictures to
Dim cell As Range
Dim Path_Prefix As String
Dim Group_Code As String
Dim temp_width As Double
Dim temp_height As Double
Dim Starting_Row As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Path_Prefix = "D:\PICTURE DATABASE\"
Starting_Row = 444
Set rng = ActiveSheet.Range(ActiveSheet.Cells(Starting_Row, Name_Column), ActiveSheet.Cells(Starting_Row, Name_Column).End(xlDown))
For Each cell In rng
If Len(Dir(Path_Prefix & "\" & cell.Value & ".jpg")) <> 0 Then
Set p = Workbooks(ActiveSheet.Parent.Name).Sheets(Sheet_to_Insert_Picture).Pictures.Insert(Path_Prefix & "\" & _
cell.Value & ".jpg")
p.Left = ActiveSheet.Cells(cell.Row, Picture_Column).Left
p.Top = ActiveSheet.Cells(cell.Row, Picture_Column).Top
cell_width = ActiveSheet.Cells(cell.Row, Picture_Column).Width
cell_height = ActiveSheet.Cells(cell.Row, Picture_Column).Height
factor = cell_width / p.Width
ActiveSheet.Cells(cell.Row, 1).RowHeight = p.Height * cell_width / p.Width
temp_width = p.Width * factor * 0.95
temp_height = p.Height * factor * 0.95
Workbooks(ActiveSheet.Parent.Name).Sheets(Sheet_to_Insert_Picture).Shapes(p.Name).Delete
Set p = Workbooks(ActiveSheet.Parent.Name).Sheets(ActiveSheet.Name).Shapes.AddPicture(Filename:=Path_Prefix & "\" & _
cell.Value & ".jpg", LinkToFile:=False, SaveWithDocument:=True, Left:=ActiveSheet.Cells(cell.Row, Picture_Column).Left + _
(ActiveSheet.Cells(cell.Row, Picture_Column).Width - temp_width) / 2, _
Top:=ActiveSheet.Cells(cell.Row, Picture_Column).Top + (ActiveSheet.Cells(cell.Row, Picture_Column).Height - temp_height) / 2, Width:=temp_width, Height:=temp_height)
End If
Next
'ActiveWorkbook.Save 'savechanges:=True
Application.DisplayAlerts = False
Application.DisplayAlerts = True
End Sub