Dim txt As String, rng As Range, I As Integer, n As String, ws As Worksheet

n = ActiveSheet.Name
For I = 1 To UBound(Regions)
    With Worksheets("Report 2" .Range("A:A" 
        txt = CStr(Regions(I))
        Set rng = .find(What:=txt, LookIn:=xlValues)
        If rng.Value Like txt & "*" Then         '<<<<============ Если открыть файл и сразу выполнить макрос, всё в порядке. Если запустить макрос повторно вылезет ошибка в этом месте. Если файл снова переоткрыть, макрос сработает. При повторном запуске макроса переменной rng не присваивается значение. Почему?
                Set ws = Worksheets.Add
                ws.Name = txt
                ws.Move After:=Worksheets(n)
        End If
    End With
Next I

Option Explicit 

Option Base 1 

Sub Count()
'выбираем файл отчёта и копируем листы "Report 2" и "Data"
Dim FileNameWI As String 'путь к файлу отчёта 
   FileNameWI = GetFilePath("Select WI report", , "Excel", "*.xls"                   'запрашиваем имя файла function GetFilePath
   If FileNameWI = "" Then Exit Sub                                                   'выходим, если пользователь отказался от выбора файла
   'MsgBox "You selected: " & FileName, vbInformation
   With Workbooks.Open(FileNameWI, ReadOnly:=True)                                    'копируем лист
    .Sheets("Report 2".Copy Before:=ThisWorkbook.Sheets(1)
    .Sheets("Data".Copy Before:=ThisWorkbook.Sheets(2)
    .Close
  End With

Dim Regions As Variant
Regions = Array("имя 1", "имя 2")

Dim txt As String, rng As Range, I As Integer, n As String, ws As Worksheet
 
n = ActiveSheet.Name
For I = 1 To UBound(Regions)
    With Worksheets("Report 2").Range("A:A")
     txt = CStr(Regions(I))
     Set rng = .find(What:=txt, LookIn:=xlValues)
     If rng.Value Like txt & "*" Then      '<<<<============ Если открыть файл и сразу выполнить макрос, всё в порядке. Если запустить макрос повторно вылезет ошибка в этом месте. Если файл снова переоткрыть, макрос сработает. При повторном запуске макроса переменной rng не присваивается значение. Почему?
          Set ws = Worksheets.Add
          ws.Name = txt
          ws.Move After:=Worksheets(n)
     End If
    End With
Next I

If rng.Value Like txt & "*" Then

Set rng = .find(What:=txt, LookIn:=xlValues,LookAt:=xlWhole)'если по части ячейки - LookAt:=xlPart

Set rng = .find(What:=txt, LookIn:=xlValues)

Set rng = .find(What:=txt, LookIn:=xlValues, LookAt:=xlPart)

Set findT = Worksheets(i).Range("E:H").Find("Полная нагрузка с потерями", , xlValues, xlPart)
    ' поиск количества вхождений
  If Not findT Is Nothing Then
    Adres = findT.Address
    Do
      cnt = cnt + 1
      Set findT = Worksheets(i).Range("E:H").FindNext(findT)
      Loop While Not findT Is Nothing And findT.Address <> Adres
  Else
    MsgBox "Не найдено на листе: " & Worksheets(i).Name
    Exit Sub
  End If

'Attribute VB_Name = "search_in_files"

Public Sub Поиск_во_всех_файлах()

Dim fso As Object
Dim fld As Object
Dim strSearch As String
Dim strPath As String
Dim strFile As String
Dim wOut As Worksheet
Dim wbk As Workbook
Dim wks As Worksheet
Dim lRow As Long
Dim rFound As Range
Dim strFirstAddress As String

On Error GoTo ErrHandler

Application.ScreenUpdating = False

strPath = "C:\ПОИСК" 'поменять на ваш путь
strSearch = InputBox("Поиск в папке C ПОИСК:", "Форма поиска", "")

If strSearch = "" Then
Exit Sub
End If

Set wOut = Worksheets.Add
lRow = 1

With wOut
.Cells(lRow, 1) = "Книга"
.Cells(lRow, 2) = "Лист"
.Cells(lRow, 3) = "Ячейка"
.Cells(lRow, 4) = "Результат"

Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strPath)
strFile = Dir(strPath & "\*.xls*")
Do While strFile <> ""
Set wbk = Workbooks.Open(fileName:=strPath & "\" & strFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
For Each wks In wbk.Worksheets
Set rFound = wks.UsedRange.Find(strSearch)
If Not rFound Is Nothing Then
strFirstAddress = rFound.Address
End If

Do
If rFound Is Nothing Then
Exit Do

Else
lRow = lRow + 1
.Cells(lRow, 1) = wbk.Name
.Cells(lRow, 2) = wks.Name
.Cells(lRow, 3) = rFound.Address
.Cells(lRow, 4) = rFound.Value
End If

Set rFound = wks.Cells.FindNext(After:=rFound)
Loop While strFirstAddress <> rFound.Address
Next
'wbk.Close (False)
strFile = Dir
Loop
.Columns("A:D").EntireColumn.AutoFit
End With

MsgBox "Все"
ExitHandler:
Set wOut = Nothing
Set wks = Nothing
Set wbk = Nothing
Set fld = Nothing
Set fso = Nothing
Application.ScreenUpdating = True
Exit Sub

ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler

End Sub