Sub xx()
    With Application
        .ScreenUpdating = 0: .EnableEvents = 0: .DisplayAlerts = False
        Open ActiveWorkbook.Path & "\1.txt" For Input As #1
        With GetObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
            .SetText Input$(LOF(1), 1)
            .PutInClipboard
        End With
        Close #1
        With [A2]
            Range(.Cells, .End(xlDown)).ClearContents
            .Cells(1).PasteSpecial xlPasteAll
            .Copy
        End With
        .CutCopyMode = 0
        .ScreenUpdating = 1: .EnableEvents = 1: .DisplayAlerts = 1
    End With
End Sub

Sub Макрос1()
    Dim fr As Frame
    For Each fr In ThisDocument.Frames
        fr.Delete
    Next fr
End Sub

Range("B2").Value = Range("B2").Value + 1

Option Explicit

Dim sl

Sub Расстановка_иконок()

ОчисткаТаблицы2
   
    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")
    pat = ActiveWorkbook.Path
    Search2 fso.GetFolder(pat)
    k = sl.keys
    With ActiveSheet
        lr = Cells(Rows.Count, 25).End(xlUp).Row
       
        ReDim m(lr - 6)
        
         m = .Range(.Cells(7, 24), .Cells(lr, 24)).Value

        
          
        Dim rw&, co&
        For rw = 11 To 37 Step 3
        For co = 11 To 21 Step 1
       
        
        For R = 1 To UBound(m)
       
        
            If Cells(rw, co) = m(R, 1) Then   ' если ячейка содержит один из кодов столбца Х
                For I = 0 To UBound(k)
                    If InStr(1, k(I), m(R, 1) & ".", vbTextCompare) > 0 Then   'исправлено, если в столбце X код совпадает с именем файла, рисуем картинку
                        pat = sl(k(I))
                        With .Cells(rw, co)
                            Set myPic = ActiveSheet.Shapes.AddPicture( _
                                Filename:=pat, _
                                linktofile:=msoFalse, _
                                savewithdocument:=msoCTrue, _
                                Left:=.Offset(0, 0).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
                        ' картинка нарисована,  выходим из цикла по i в цикл по r
                        GoTo next_r  ' исправлено
                    Else 'если в столбце X код не совпадает с именем файла, рисуем картинку
                    End If
                    
                    
                Next I
            End If
next_r:
        Next R
        Next co
        Next rw
    End With
End Sub

 Function Search2(Fold As Object)  
 Dim SubFold As Object, Fil As Object

   For Each SubFold In Fold.SubFolders
     Search2 SubFold
   Next SubFold
   For Each Fil In Fold.Files
        If InStr(1, Fil.Name, ".png", vbTextCompare) > 0 Then
        sl(Fil.Name) = Fil.Path
        End If
   Next Fil
End Function


Sub ОчисткаТаблицы2()  'Очищает таблицу от картинок, чтобы они не наслаивались при каждом срабатывании
    Dim pic As Shape
    ActiveSheet.Unprotect
    For Each pic In ActiveSheet.Shapes
        If pic.Type = msoPicture Then
            If Not Application.Intersect(pic.TopLeftCell, Range("K11:U40")) Is Nothing Then
                pic.Delete
            End If
        End If
    Next pic
End Sub

Private Type CellPoint
    X As Single
    Y As Single
    vl As Variant
End Type
Sub Test()
    Dim X As Single, Y As Single, t() As CellPoint, paralast As Long
    Dim Sh As Worksheet
    Set Sh = ActiveSheet
    paralast = -1
    ReDim ListPoint(0)
    For Each cel In Sh.UsedRange.Cells
        If Not (Trim(cel.Value) = "" Or Trim(cel.Value) = 0) Then
            paralast = paralast + 1
            ReDim Preserve ListPoint(paralast)
            X = cel.Left + cel.Width / 2
            Y = cel.Top + cel.Height / 2
            ListPoint(paralast).X = X
            ListPoint(paralast).Y = Y
            ListPoint(paralast).vl = Trim(cel.Value)
        End If
 
    Next
    For Each Shap In Sh.Shapes
        If Shap.AutoShapeType = msoShapeOval Then
            With Shap.DrawingObject.ShapeRange
                X = .Left + .Width / 2
                Y = .Top + .Height / 2
                Name_ = .Name
                Debug.Print Name_, X, Y
            End With
        End If
    Next
 
End Sub