Посмотрите пример макроса здесь: http://programmersforum.ru/showpost.php?p=347651&postcount=3  
 
 
Вот пример кода макроса:  
 
 
Public FileNames As Collection  
 
Sub Main()  
   On Error Resume Next  
   ' оставьте одну из следующих двух строк:  
   ПутьКПапкеСКартинками = "C:\Documents and Settings\Игорь\Рабочий стол\тест" ' конкретный файл  
   ПутьКПапкеСКартинками = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "") ' там же, где и этот файл  
     
   Application.ScreenUpdating = False: msg = "": Application.DisplayAlerts = False  
   Dim sh As Worksheet: Set sh = ActiveSheet  
   Очистка    ' очистка всех ячеек листа от прежнего содержимого  
   Set FileNames = New Collection: On Error Resume Next  
   Call ReadFileNames(ПутьКПапкеСКартинками)    ' поиск подходящих файлов во всех подпапках  
     
   Dim cell As Range, ra As Range: Application.ScreenUpdating = False  
   Set ra = Range([A2], Range("A" & Rows.Count).End(xlUp))
   For Each cell In ra.Cells  
       fileNumber = cell.Text: Err.Clear  
       If Len(fileNumber) = 6 Then  
           FilePath = "": FilePath = FileNames(fileNumber & "a")  
           If Err.Number = 0 Then ВставитьКартинку cell.Next, FilePath  
       End If  
   Next cell  
   Application.ScreenUpdating = True  
End Sub  
 
Sub Очистка()  
   Dim sha As Shape: Application.ScreenUpdating = False  
   For Each sha In ActiveSheet.Shapes  
       If sha.Type = msoPicture Then sha.Delete  
   Next  
   ActiveSheet.UsedRange.EntireRow.AutoFit  
End Sub  
 
Sub ВставитьКартинку(ByRef cell As Range, ByVal Pic As String)  
   On Error Resume Next  
   Dim ph As Picture: Set ph = cell.Parent.Pictures.Insert(Pic)  
   ph.Top = cell.Top: ph.Left = cell.Left: k = ph.Width / ph.Height  
   ph.Width = cell.Width: ph.Height = ph.Width / k  
   cell.EntireRow.RowHeight = ph.Height  
End Sub  
 
Function ReadFileNames(ByVal FolderPath As String)  
   Set fso = CreateObject("scripting.filesystemobject")  
   Set curfold = fso.GetFolder(FolderPath)  
 
   If Not curfold Is Nothing Then  
       For Each fil In curfold.Files  
           If fil.Name Like "*.jpg" Then FileNames.Add fil.Path, Left(fil.Name, 6) & "a"  
       Next  
       For Each sfol In curfold.SubFolders  
           ReadFileNames sfol.Path  
       Next  
       Set fil = Nothing: Set curfold = Nothing: Set fso = Nothing:  
   End If  
End Function