set sn = ActiveSheet.Cells(i, 2) 'следующий серийник

Sub Найти_полный_sn()
    Dim Путь As String, Файл As String, sn As Range, FirstCell As Range, Совпадений As Integer
    Dim sh As Worksheet
    Dim Книга As Excel.Workbook
    
    'выбираем папку с файлами-источниками информации
    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "OK"
        .Title = "Выберите папку, содержащую файлы Excel"
        If .Show = 0 Then
            Exit Sub
        End If
        Путь = .SelectedItems(1)
    End With
    Файл = Dir(PathName:=Путь + "\*.xls")
    i = 2
    Set sn = ActiveSheet.Cells(i, 2)
    
    Do Until sn.Value = "" 'пока не закончатся серийные номера в столбце
       Совпадений = 0
       Do Until Файл = "" 'пока не закончатся файлы в выбранной папке
           Set Книга = Workbooks.Open(Путь + "\" + Файл)
           For Each sh In Книга.Sheets 'поиск по листам
               sh.Activate
               Set rng = sh.UsedRange.Find(What:=sn.Value, LookIn:=xlValues, LookAt:=xlPart)
                If Not (rng Is Nothing) Then
                    Set FirstCell = rng
                    If Совпадений = 0 Then
                        Совпадений = 1
                    Else
                        Совпадений = Совпадений + 1
                    End If
                    sn.Offset(0, Совпадений).Value = rng.Value
                    Do Until rng Is Nothing Or rng Is FirstCell
                        Set rng = sh.UsedRange.FindNext(rng)
                        If Not (rng Is Nothing) Then
                            Совпадений = Совпадений + 1
                            sn.Offset(0, Совпадений).Value = rng.Value
                        End If
                    Loop
                End If
           Next sh
           Книга.Close
           Файл = Dir
       Loop
       i = i + 1
       Set sn = ActiveSheet.Cells(i, 2) 'следующий серийник
    Loop
    Set Книга = Nothing
End Sub

Sub br()
    ' Set sh = ActiveSheet
    Set Rng = sh.UsedRange.Find(What:="a", LookIn:=xlValues, LookAt:=xlPart)
    If Not (Rng Is Nothing) Then
        s = Rng.Address
        Совпадений = Совпадений + 1
        Do
            Set Rng = sh.UsedRange.FindNext(Rng)
            If Rng.Address = s Then s = "": Set Rng = Nothing: Exit Do
            Совпадений = Совпадений + 1
        Loop
    End If
End Sub

Dim objFSO As Object, objFolder As Object, objFile As Object, Совпадений As Integer

Sub Get_All_from_SubFolders()
    Dim sFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    i = 2
    Set sn = ActiveSheet.Cells(i, 1)
    
    Do Until sn.value = "" 'пока не закончатся серийные номера в столбце
       Совпадений = 0
       GetSubFolders sFolder, sn, Совпадений
       Set objFolder = Nothing
       Set objFSO = Nothing

       i = i + 1
       Set sn = ActiveSheet.Cells(i, 1) 'следующий серийник
    Loop
    
    Application.ScreenUpdating = True
End Sub

Private Sub GetSubFolders(sPath, sn, Совпадений)
    Dim sPathSeparator As String, sObjName As String, rng As Range
    Dim sh As Worksheet
    
    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        If Replace(objFile.Name, objFSO.GetBaseName(objFile), "") Like ".xls*" Then
            'открываем книгу
            Workbooks.Open sPath & objFile.Name
                For Each sh In ActiveWorkbook.Sheets 'поиск по листам
                   Set rng = sh.UsedRange.Find(What:=sn.value, LookIn:=xlValues, LookAt:=xlPart)
                    If Not (rng Is Nothing) Then
                        s = rng.Address
                        Совпадений = Совпадений + 1
                        sn.Offset(0, Совпадений).value = rng.value & " " & rng.Offset(0, -1).value & " в " & sPath & objFile.Name
                        Do
                            Set rng = sh.UsedRange.FindNext(rng)
                            If Not (rng Is Nothing) And rng.Address <> s Then
                                Совпадений = Совпадений + 1
                                sn.Offset(0, Совпадений).value = rng.value & " " & rng.Offset(0, -1).value & " в " & sPath & objFile.Name
                            End If
                        Loop Until rng Is Nothing Or rng.Address = s
                    End If
    
                Next sh
            ActiveWorkbook.Close True
        End If
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders objFolder.Path & Application.PathSeparator, sn, Совпадений
    Next
End Sub