Option Explicit
Sub Поиск_во_всех_файлах()
Dim iShtName$, iPath, iPathArr, iFileName$, firstAddress$
Dim iSheet As Worksheet, iFoundSht As Worksheet
Dim iTempWB As Workbook, iBazaWB As Workbook
Dim TextToFind As Variant, iFoundRng As Range
Dim iLastRow&
Dim FoundAny As Boolean
  
    TextToFind = Application.InputBox("Введите текст для поиска:", "Поиск")
    If TextToFind = "" Or TextToFind = False Then Exit Sub
    TextToFind = Trim(TextToFind)
    
    'Здесь пути к Вашим папкам, нужен слеш в конце
    iPathArr = Array("D:\ExcelFolder\", "D:\ExcelFolder2\")
    
    For Each iPath In iPathArr
        Workbooks.Add
        Sheets.Add.Name = "Поиск"
        Set iFoundSht = ActiveSheet
        iFoundSht.Cells(1, 1) = "Ищем: " & TextToFind
        iFoundSht.Cells(1, 1).Font.Bold = True
        With Application
            .ScreenUpdating = False
            .Calculation = xlManual
            .StatusBar = "Идёт поиск..."
            .ShowWindowsInTaskbar = False
            iFileName = Dir(iPath & "*.xls")
            Do While iFileName$ <> ""
                Set iTempWB = Workbooks.Open(Filename:=iPath & iFileName, UpdateLinks:=False, ReadOnly:=True)
                For Each iSheet In iTempWB.Sheets
                    If iSheet.FilterMode = True Then iSheet.ShowAllData
                    Set iFoundRng = iSheet.Cells.Find(What:=TextToFind, LookIn:=xlFormulas, LookAt:=xlPart)
                    If Not iFoundRng Is Nothing Then
                        FoundAny = True
                        firstAddress = iFoundRng.Address
                        Do
                            With iFoundSht
                                iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                                If iLastRow = 1 Then iLastRow = 2
                                If iShtName <> iSheet.Name Then    'если новый файл
                                    With .Cells(iLastRow + 2, 1)
                                        .Value = "Файл: " & iTempWB.Name & ", Лист: " & iSheet.Name
                                        .Font.Bold = True
                                    End With
                                End If
                                iFoundRng.EntireRow.Copy Destination:=.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1)    'копируем всю строку
                                iShtName = iSheet.Name
                            End With
                            Set iFoundRng = iSheet.Cells.FindNext(iFoundRng)
                        Loop While iFoundRng.Address <> firstAddress
                    Else
                    End If
                Next
                iTempWB.Close SaveChanges:=False
                iFileName = Dir
            Loop
            .StatusBar = False
            .ShowWindowsInTaskbar = True
            .EnableEvents = True
            .Calculation = xlCalculationAutomatic
            .ScreenUpdating = True
        End With
        If FoundAny = False Then
            MsgBox "Текст '" & TextToFind & "' ни в одном из файлов в папке:" & Chr(10) & iPath & Chr(10) & " не был найден!", 48, "Отчёт"
            iFoundSht.Parent.Close SaveChanges:=False
            Exit Sub
        End If
    Next iPath
    MsgBox "Поиск " & TextToFind & " завершён!", 64, "Поиск"
End Sub

Option Explicit
Private WithEvents cmbrs As CommandBars

Private Sub Workbook_Activate()
    Set cmbrs = Application.CommandBars
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Set cmbrs = Application.CommandBars
End Sub

Private Sub cmbrs_OnUpdate()
    Call ManipulateImage
End Sub

Private Sub ManipulateImage()
    Dim shp As Shape, shpPosition As String, shpName As String, shpCheck As Shape
    Set shp = GetShape
    If Not shp Is Nothing And ActiveSheet.Index = 1 Then
        shpName = shp.Name
        For Each shpCheck In Worksheets(2).Shapes
            If shpCheck.Name = shpName Then
                End
            End If
        Next shpCheck
        Let shpPosition = shp.TopLeftCell.Address(0, 0)
        shp.Copy
        shp.Delete
        Worksheets(2).Activate
        Worksheets(2).Paste Range(shpPosition)
        Worksheets(1).Activate
        'Worksheets(2).Shapes(Worksheets(2).Shapes.Count).Name = shpName
    End If
End Sub

Private Function GetShape() As Shape
    If TypeName(Selection) = "Picture" Then Set GetShape = Application.Selection.ShapeRange.Item(1)
End Function

Sub Макрос1()
    
    A = Sheets("Лист1").Cells(2, 1).Value
    Set Rng = Sheets("Sheet1").Columns(2).Find(A, LookIn:=xlValues, LookAt:=xlWhole)
    If Not Rng Is Nothing Then
        myRow = Rng.Row
    End If
    
    For i = 2 To Sheets("Лист1").Cells(2, Columns.Count).End(xlToLeft).Column
        B = Sheets("Лист1").Cells(2, i).Value
    
        Set Rng1 = Sheets("Sheet1").Rows(1).Find(B, LookIn:=xlValues, LookAt:=xlWhole)
        If Rng1 Is Nothing Then
            Set Rng1 = Sheets("Sheet1").Rows(1).Find(Split(B, " ")(0), LookIn:=xlValues, LookAt:=xlPart)
            If Not Rng1 Is Nothing Then
                Sheets("Sheet1").Columns(Rng1.Column + 1).Insert
                Sheets("Sheet1").Cells(1, Rng1.Column + 1) = Sheets("Лист1").Cells(2, i)
                Sheets("Sheet1").Cells(2, Rng1.Column + 1) = Sheets("Лист1").Cells(3, i)
                Sheets("Sheet1").Cells(3, Rng1.Column + 1) = Sheets("Лист1").Cells(4, i)
            Else
                x = Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
                Columns(x + 1).Insert
                Sheets("Sheet1").Cells(1, x + 1) = Sheets("Лист1").Cells(2, i)
                Sheets("Sheet1").Cells(2, x + 1) = Sheets("Лист1").Cells(3, i)
                Sheets("Sheet1").Cells(3, x + 1) = Sheets("Лист1").Cells(4, i)
            End If
        Else
            myColumn = Rng1.Column
            Sheets("Sheet1").Cells(myRow, myColumn) = Sheets("Лист1").Cells(4, i)
        End If
    Next i

End Sub