Sub GEGJ()
Dim oWB As Workbook
Dim rCell As Range, rSearchRange As Range
Dim sFolder$, sCode$, sFileName$
Dim oFso As Object
Dim oFolder As Object

Set oWB = ActiveWorkbook
sFolder = "D:\" 'я пишу Д, вы свою
'Я пишу лист1, вы своё название листа
Set rSearchRange = oWB.Sheets("Лист1").Range("B1:B" & Sheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row)

For Each rCell In rSearchRange
    If Not IsEmpty(rCell.Value) Then
        sCode = "-" & Right(rCell.Value, Len(rCell.Value) - InStrRev(rCell.Value, "-"))
        Set oFso = CreateObject("Scripting.FileSystemObject")
        Set oFolder = oFso.GetFolder(sFolder)
        Call RecursiveSubFolders(oFolder, sCode, oWB)
    Else
        Exit Sub
    End If
Next rCell
Set oFso = Nothing
End Sub
Sub RecursiveFiles(ByRef oFolder As Object, ByVal sCode As String, ByRef oWB As Workbook)
Dim oFile As Object
Dim sFilePath As String
    For Each oFile In oFolder.Files
        sFil = oFile.Name
        If InStr(oFile.Name, sCode) >= 1 Then
            sFilePath = oFile.Path
            oWB.Sheets("Лист1").Range("L" & rCell.Row) = "=HYPERLINK(" & sFilePath & ")"
        End If
    Next oFile
End Sub
Sub RecursiveSubFolders(ByRef oFolder As Object, ByVal sCode As String, ByRef oWB As Workbook)
Dim oSubFolder As Object
    If oFolder.Subfolders.Count >= 1 Then
        For Each oSubFolder In oFolder.Subfolders
            Call RecursiveFiles(oFolder, sCode, oWB)
            If oFolder.Subfolders.Count >= 1 Then
                Call RecursiveSubFolders(oSubFolder, sCode, oWB)
            End If
        Next oSubFolder
    Else
        Call RecursiveFiles(oFolder, sCode, oWB)
    End If
End Sub

For Цикл = 1 to 2
Select Case Цикл
'сюда пишем  для входящих
Case 1:
sFolder = "ваш путь"
'сюда пишем  для исходящих
Case 2:
sFolder = "ваш путь"
End Select
'А сюда код из основной процедуры
Next Цикл

Sub GetHyperlinksForFilesWithCodeNameFromB()
Dim oWB As Workbook
Dim rCell As Range, rSearchRange As Range
Dim sFolder$, sCode$, sFileName$, sSheetName$, sVal$
Dim oFso As Object
Dim oFolder As Object

Set oWB = ActiveWorkbook
sSheetName = "Лист1" 'Я пишу лист1, вы своё название листа
Set rSearchRange = oWB.Sheets(sSheetName).Range("B1:B" & Sheets(sSheetName).Cells(Rows.Count, 2).End(xlUp).Row)

For Each rCell In rSearchRange
    If Not IsEmpty(rCell.Value) Then
        sVal = rCell.Value
        sCode = Right(sVal, Len(sVal) - InStrRev(sVal, "-"))
        sVal = Left(sVal, Len(sVal) - Len(sCode) - 1)
        sCode = Right(sVal, Len(sVal) - InStrRev(sVal, "-")) & "-" & sCode
        For Цикл = 1 To 2
            Select Case Цикл
                'сюда пишем  для входящих
                Case 1:
                    sFolder = "D:\Входящие" 'Например "D:\Входящие\"
                    sCol = "L" 'Столбец, куда будем вставлять
                'сюда пишем  для исходящих
                Case 2:
                    sFolder = "D:\Исходящие" 'Например "D:\Исходящие\"
                    sCol = "K" 'Столбец, куда будем вставлять
            End Select
            'А сюда код из основной процедуры
            
            Set oFso = CreateObject("Scripting.FileSystemObject")
            Set oFolder = oFso.GetFolder(sFolder)
            Call RecursiveSubFolders(oFolder, sCode, oWB, sCol, sSheetName, rCell)
        Next Цикл
    Else
        Exit Sub
    End If
Next rCell
Set oFso = Nothing
End Sub

Sub RecursiveFiles(ByRef oFolder As Object, ByVal sCode As String, ByRef oWB As Workbook, _
                            ByVal sCol As String, ByVal sSheetName As String, ByRef rCell As Range)
Dim oFile As Object
Dim sFilePath As String
    For Each oFile In oFolder.Files
        sFil = oFile.Name
        If InStr(oFile.Name, sCode) >= 1 Then
            sFilePath = oFile.Path
            oWB.Sheets(sSheetName).Hyperlinks.Add Anchor:=oWB.Sheets(sSheetName).Range(sCol & rCell.Row), _
                    Address:=sFilePath, TextToDisplay:=Format(Date, "dd.mm.yyyy")
        End If
    Next oFile
End Sub

Sub RecursiveSubFolders(ByRef oFolder As Object, ByVal sCode As String, ByRef oWB As Workbook, _
                            ByVal sCol As String, ByVal sSheetName As String, ByRef rCell As Range)
Dim oSubFolder As Object
    If oFolder.Subfolders.Count >= 1 Then
        For Each oSubFolder In oFolder.Subfolders
            Call RecursiveFiles(oFolder, sCode, oWB, sCol, sSheetName, rCell)
            If oFolder.Subfolders.Count >= 1 Then
                Call RecursiveSubFolders(oSubFolder, sCode, oWB, sCol, sSheetName, rCell)
            End If
        Next oSubFolder
    Else
        Call RecursiveFiles(oFolder, sCode, oWB, sCol, sSheetName, rCell)
    End If
End Sub