Application.DisplayAlerts = False
.....
.....
.....
Application.DisplayAlerts = True

Private file_name As String
Private f As File, fld As folder

Sub SearchAndOpen()

    Dim source_folder As String
    Dim fso As New FileSystemObject

    'Папка для поиска
    source_folder = "C:\Temp\Dir\"
    
    'Ячейка с именем файла
    file_name = Range("A1")
    
    Call EnumerateFiles(fso.GetFolder(source_folder))

End Sub

Private Sub EnumerateFiles(root_folder As folder)

    For Each f In root_folder.Files
        If f.Name = file_name Then
            Workbooks.Open f.Path
        End If
    Next
    
    For Each fld In root_folder.SubFolders
        Call EnumerateFiles(fld)
    Next
    
End Sub

    Const baseFolder = "d:\project"

Sub ARM()
    Dim f As String, folder As String, file_name As String
    'Папка для поиска
    folder = "C:\Documents and Settings\maks\Рабочий стол\Документы\"
    'Ячейка с именем файла
    file_name = LCase(Range("D1")) & ".xls"
    f = Dir(folder)
    While Not Len(f) = 0
        If LCase(f) = file_name Then

            Workbooks.Open folder & f
           
 Application.Run "ARM.XLS!ARM6"
            Exit Sub
        End If
        f = Dir()
    Wend

    Application.Run "ARM.XLS!ARM4"
End Sub

Sub Copy_Paste()

Dim objWrdApp As Object
Dim objWrdDoc As Object
Dim NameFile As String, NameFolder As String
Dim lCol As Long, aTbl As Long, i As Long, j As Long, lastRow3 As Long

NameFolder = Range("B1").Value & "\"
NameFile = NameFolder & Range("B2") & ".docx"

    On Error Resume Next
    Set objWrdApp = GetObject(, "Word.Application")
    If objWrdApp Is Nothing Then
        Set objWrdApp = CreateObject("Word.Application")
        Set objWrdDoc = objWrdApp.Documents.Open("\\x-srv63-x\xxxx\xxxx\xxxx\1\xxxx\" & NameFile)
            objWrdDoc.Activate
            objWrdApp.Visible = True
    End If

'lCol = objWrdDoc.tables.Count
'
'For aTbl = 2 To lCol - 1
'    ReDim arr(1 To objWrdDoc.tables(aTbl).Rows.Count, 1 To objWrdDoc.tables(aTbl).Columns.Count)
'        For j = 1 To UBound(arr, 2)
'            For i = 2 To UBound(arr, 1)
'                arr(i, j) = Trim(Replace(objWrdDoc.tables(aTbl).cell(i, j).Range.Text, Chr(7), ""))
'            Next i
'        Next j
'
'    With Sheets("ID")
'        lastRow3 = ThisWorkbook.Worksheets("ID").Range("A" & Rows.Count).End(xlUp).Row
'    End With
'
'        ThisWorkbook.Sheets("ID").Range("A" & lastRow3 + 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
'
'    If Range("A" & lastRow3 + 1) = "" Then
'        Range("A" & lastRow3 + 1).EntireRow.Delete
'    End If
'
'Next

End Sub