Найти и скопировать в отдельную папку все файлы по маске

Private Sub cmd_ok_Click()
 
 
Dim sFilesPath As String, sNewPath As String, sMask As String
Dim sFolder As String, sFiles As String, SubFolder As String, sDoc As String
Dim sFile As String
 
 
 
If txt_banum.Text = "" Or Len(txt_banum.Text) < 13 Then
    MsgBox "НЕДОСТАТОЧНО СИМВОЛОВ!", vbCritical
    'Selection.AutoFilter
    Exit Sub
End If
 
 
lLastRow = Cells.SpecialCells(xlLastCell).Row
 
 
Set iskk = Sheets(2).Range("A:A").Find(txt_banum.Text, lookat:=xlWhole)
 
 
If Not iskk Is Nothing Then
ActiveSheet.Range("$A$1:$D$" & lLastRow).AutoFilter Field:=1, Criteria1:=txt_banum.Text
 
 
 
Range("$A$1:$D$" & lLastRow).Copy
Sheets("CurrData").Cells.Delete
Selection.Copy Sheets("CurrData").Range("A1")
Sheets("CurrData").Columns("A:D").ColumnWidth = 20
 
 
Selection.AutoFilter
Dim username1
Dim path As String
 
username1 = Environ("USERNAME")
path = "C:\Users" & "" & username1 & "" & "Desktop" & "" & txt_banum.Value
check = Dir(path & Application.PathSeparator, vbDirectory)
 
With ThisWorkbook.Sheets("CurrData")
        If Len(check) > 0 Then
        MsgBox ("Папка " & txt_banum.Value & " уже существует")
        Else
        MkDir path
        End If
        NewPath = path & Application.PathSeparator & "Summary" & ".xlsx"
        ThisWorkbook.Sheets("CurrData").Copy
        ActiveWorkbook.SaveAs (NewPath)
        ActiveWorkbook.Close
End With
ThisWorkbook.Activate
 
sNewPath = path & Application.PathSeparator 'куда перемещать файлы
 
Application.ScreenUpdating = False
        kon = Sheets("CurrData").Range("I10000").End(xlUp).Row
            'kona = Sheets("CurrData").Range("C10000").End(xlUp).Row
        For i = 2 To kon
            SubFolder = Sheets("CurrData").Cells(i, 9).Value
            sDoc = Sheets("CurrData").Cells(i, 3).Value
 
 
sFilesPath = ThisWorkbook.path & "" & SubFolder & Application.PathSeparator 'откуда перемещать файлы
sMask = sDoc
 
    sFolder = sFilesPath
    sFiles = Dir(sFolder)
    
    Do While sFiles <> ""
        If InStr(sFiles, sMask) < 2 Then
    
            FileCopy sFolder & Application.PathSeparator & sFiles, sNewPath & Application.PathSeparator & sFiles
        End If
        sFiles = Dir
    Loop
 
 
    Application.ScreenUpdating = True
Next
 
txt_banum.Value = ""
MsgBox "Пакет документов создан в директории " & path
 
uf_main.Hide
 
Selection.AutoFilter
 
        Else: MsgBox "Номер не Найден!", vbCritical
        Sheets("CurrData").Cells.Delete
        Sheets(2).Select
        lLastRow = Cells.SpecialCells(xlLastCell).Row
        End If
 
End Sub