Option Explicit
Dim sl

Sub Макрос1()

    Dim r, lr, m, k, pat, i, f
    Dim myPic As Shape
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set sl = CreateObject("Scripting.Dictionary")
    pat = ActiveWorkbook.Path
    Search fso.GetFolder(pat)
    k = sl.keys
    With ActiveSheet
        lr = Cells(Rows.Count, 25).End(xlUp).Row
        m = .Cells(4, 24).Resize(lr - 3, 2).Value
        Dim rw&, co&
        For rw = 42 To 51 Step 3
        For co = 6 To 10 Step 1
        For r = 1 To UBound(m)
            If InStr(Cells(rw, co), m(r, 1)) > 0 Then
                For i = 0 To UBound(k)
                    If InStr(1, k(i), m(r, 2), vbTextCompare) > 0 Then
                        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
                    End If
                Next i
            End If
        Next r
        Next co
        Next rw
    End With
End Sub

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

   For Each SubFold In Fold.SubFolders
     Search 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 SetMakro()
Dim iShape As Shape
For Each iShape In Worksheets("Лист2").Shapes
On Error Resume Next
  If iShape.DrawingObject.Caption <> "Назначить кнопки" Then
    iShape.OnAction = "RunEXE"
  End If
Next
End Sub

Private Sub RunEXE()
Dim iShape As Shape
Dim iEXE$
On Error Resume Next
Set iShape = Worksheets("Лист2").Shapes(Application.Caller)
If Not iShape Is Nothing Then
  With Worksheets("Лист2")
    iEXE = Application.WorksheetFunction.VLookup(iShape.DrawingObject.Caption, .Range("AC5:AD" & .Cells(.Rows.Count, "AC").End(xlUp).Row), 2, 0)
  End With
  If Not IsEmpty(iEXE) Then
    Shell iEXE, vbNormalFocus
  End If
End If
End Sub

Sub pr()
    a = Range("B4").CurrentRegion.Value
    For i = 1 To UBound(a)
        ActiveSheet.Shapes(a(i, 1)).OnAction = a(i, 2)
    Next
End Sub

Sub pr2()
    a = Range("U13").CurrentRegion.Value
    For i = 1 To UBound(a)
        ActiveSheet.Shapes.TextFrame2.TextRange.Characters.Text(a(i, 1)).OnAction = "RunEXE"
    Next
End Sub

Function Шрифт1(S)
 
    Dim rngTarget As Range
    Set rngTarget = Range("D9")
    ' - -
    Dim rngCell As Range
    ' - -
    For Each rngCell In rngTarget
        ' - -
        With rngCell
            ' - -
            If .Value = 1 Then
                .Font.Name = "Times New Roman"
            Else
                .Font.Name = "Arial"
            End If '.Value = 1
            ' - -
        End With 'rngCell
        ' - -
    Next rngCell
     
End Function