Dim sl



Sub Расстановка_иконок()
t = Timer
Application.ScreenUpdating = False
ОчисткаТаблицы

    Dim R, lr, k, pat, I, f
    Dim m() As Variant
   
    Dim myPic As Shape
    Dim FSO As Object
    'Set FSO = CreateObject("Scripting.FileSystemObject")
    Set sl = CreateObject("Scripting.Dictionary")
    Set sl2 = CreateObject("Scripting.Dictionary")
    Search2 ActiveWorkbook.Path
    k = sl.keys
  
    Set D = ActiveSheet.Range("H:H,L:L,P:P,T:T,X:X,AB:AB,AF:AF,AJ:AJ,AN:AN,AQ:AQ,AT:AT,AW:AW,AZ:AZ,BD:BD,BH:BH")
    Set D = Intersect(D, Range("13:54")).SpecialCells(xlCellTypeConstants)
    For Each cell In D
    If cell <> "" Then
    Lcell = LCase(cell)
    If sl2.Exists(Lcell) Then
        If sl2(Lcell) > 0 Then
            ActiveSheet.Shapes(sl2(Lcell)).Duplicate
            With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
                .Top = cell.Offset(0, -1).Top + 1
                .Left = cell.Offset(0, -1).Left + 1
                .Width = cell.Offset(0, -1).Width - 2
                .Height = cell.Offset(0, -1).Height * 3 - 2
            End With
        End If
        Else
            If sl.Exists(Lcell) Then
                Set myPic = ActiveSheet.Shapes.AddPicture( _
                    Filename:=sl(Lcell), _
                    linktofile:=msoFalse, _
                    savewithdocument:=msoCTrue, _
                    Left:=cell.Offset(0, -1).Left + 1, _
                    Top:=cell.Offset(0, -1).Top + 1, _
                    Width:=cell.Offset(0, -1).Width - 2, _
                    Height:=cell.Offset(0, -1).Height * 3 - 2)
                myPic.LockAspectRatio = msoFalse
            sl2(Lcell) = ActiveSheet.Shapes.Count
            End If
        End If
        End If
    Next
'    For Each PicName In k
'        'With d
'        Set m_rnFind = D.Find(What:=PicName, LookAt:=xlWhole, MatchCase:=False)
'        If Not m_rnFind Is Nothing Then
'            m_stAddress = m_rnFind.Address
'            'Hide the column, and then find the next X.
'             With m_rnFind
'                Set myPic = ActiveSheet.Shapes.AddPicture( _
'                                Filename:=sl(PicName), _
'                                linktofile:=msoFalse, _
'                                savewithdocument:=msoCTrue, _
'                                Left:=.Offset(0, -1).Left + 1, _
'                                Top:=.Offset(0, -1).Top + 1, _
'                                Width:=.Offset(0, -1).Width - 2, _
'                                Height:=.Offset(0, -1).Height * 3 - 2)
'                myPic.LockAspectRatio = msoFalse
'              End With
'
'              ' [-]
'              ' ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Copy
'              '
'            Do
'                If m_rnFind.Address <> m_stAddress Then
'
'                    ' [-]
'                    'ActiveSheet.Paste
'                    '
'                    ' [+]
'                    myPic.Duplicate
'                    '
'
'                    With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
'                        .Top = m_rnFind.Offset(0, -1).Top + 1
'                        .Left = m_rnFind.Offset(0, -1).Left + 1
'                        .Width = m_rnFind.Offset(0, -1).Width - 2
'                        .Height = m_rnFind.Offset(0, -1).Height * 3 - 2
'                    End With
'                End If
'                Set m_rnFind = D.FindNext(m_rnFind)
'                On Error Resume Next
'            Loop While Not m_rnFind Is Nothing And m_rnFind.Address <> m_stAddress
'        End If
'        Next
    
Range("A1").Select
Application.ScreenUpdating = True
Debug.Print Timer - t
End Sub


 Function Search2(Fold As String)  
 Dim SubFold As Object, Fil As Object, FSO As Object
    Set objShellApp = CreateObject("Shell.Application")
    Set FSO = CreateObject("Scripting.FileSystemObject")

   Set objFolder = objShellApp.Namespace(Fold & "\")
   Set objFolderItems = objFolder.Items()
   objFolderItems.Filter 64, "*.png;*.jpg"
   For Each Fil In objFolderItems
     sl(LCase(FSO.Getbasename(Fil.Path))) = Fil.Path
   Next
   objFolderItems.Filter 32, "*"
   For Each SubFold In objFolderItems
     Search2 SubFold.Path
   Next SubFold
End Function


Sub ОчисткаТаблицы()  
    Dim pic As Shape
    Application.ScreenUpdating = False
    ActiveSheet.Unprotect
    For Each pic In ActiveSheet.Shapes
        If pic.Type = msoPicture Then
            If Not Application.Intersect(pic.TopLeftCell, Range("G13:BI54")) Is Nothing Then
                pic.Delete
            End If
        End If
    Next pic
    Application.ScreenUpdating = True
End Sub