Function GetNewFileName() As String

    Dim fso As New FileSystemObject
    Dim fName As String
    Dim num As String
    Dim fileToOpen As Variant
    Dim newName As String
    
    fileToOpen = Application.GetOpenFilename("Text Files (*.xls), *.xls")
    fName = fso.GetBaseName(fileToOpen)
    num = Right(fName, Len(fName) - InStr( 1 , fName, "-", VbCompareMethod.vbTextCompare))
    
    newName = "Набор-" & num

End Function

Function GetNewFileName() As String

    Dim fso As New FileSystemObject
    Dim fName As String
    Dim num As String
    Dim fileToOpen As Variant
    Dim newName As String
    
    fileToOpen = Application.GetOpenFilename("Text Files (*.xls), *.xls")
    fName = fso.GetBaseName(fileToOpen)
    num = Right(fName, Len(fName) - InStr( 1 , fName, "-", VbCompareMethod.vbTextCompare))
    
    newName = "Итог-" & num
    
    GetNewFileName = newName

End Function

Option Explicit

Sub CreateNewFiles()

    Dim fd As FileDialog
    Dim fso As New FileSystemObject
    Dim aFile As File, sExtension As String
    Dim sFullPath As String
    Dim rootFolder As String
    Dim subFolder As String
    Dim num As String
    Dim newName As String
    
    ' Select target folder.
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = False Then Exit Sub
    rootFolder = fd.SelectedItems( 1 )
    
    ' Create new sub-folder.
    subFolder = rootFolder & "\NewFiles"
    If fso.FolderExists(subFolder) Then fso.DeleteFolder subFolder, True
    fso.CreateFolder subFolder
    
    For Each aFile In fso.GetFolder(rootFolder).Files
        sExtension = fso.GetExtensionName(aFile.Name)
        If sExtension Like "xls*" Then
            ' Copy this file to sub-folder.
            fName = fso.GetBaseName(aFile.Name)
            num = Right(fName, Len(fName) - InStr( 1 , fName, "-", VbCompareMethod.vbTextCompare))
            newName = "Итог-" & num
            sFullPath = subFolder & "\" & newName & "." & sExtension
            aFile.Copy sFullPath
        End If
    Next
    
End Sub

Dim fName As String

Option Explicit

Sub CreateNewFiles()

    Dim fd As FileDialog
    Dim fso As New FileSystemObject
    Dim aFile As File, sExtension As String
    Dim sFullPath As String, fName As String
    Dim sMask As String
    Dim rootFolder As String
    Dim subFolder As String
    Dim num As String
    Dim newName As String
    
    ' Select target folder.
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = False Then Exit Sub
    rootFolder = fd.SelectedItems( 1 )
    
    ' Define mask.
    sMask = "Набор-*"
    
    ' Create new sub-folder.
    subFolder = rootFolder & "\NewFiles"
    If fso.FolderExists(subFolder) Then fso.DeleteFolder subFolder, True
    fso.CreateFolder subFolder
    
    For Each aFile In fso.GetFolder(rootFolder).Files
        sExtension = fso.GetExtensionName(aFile.Name)
        If sExtension Like "xls*" Then
            ' Copy this file to sub-folder.
            fName = fso.GetBaseName(aFile.Name)
            If fName Like sMask Then
                num = Right(fName, Len(fName) - InStr( 1 , fName, "-", VbCompareMethod.vbTextCompare))
                newName = "Итог-" & num
                sFullPath = subFolder & "\" & newName & "." & sExtension
                aFile.Copy sFullPath
            End If
        End If
    Next
    
End Sub

Option Explicit
Option Compare Text

Sub CreateNewFiles()

    Dim fd          As FileDialog
    Dim fso         As New FileSystemObject
    Dim aFile       As File
    Dim sMask       As String
    Dim sNumber     As String
    Dim sNewName    As String
    Dim sFileName   As String
    Dim sFullPath   As String
    Dim sExtension  As String
    Dim sSubFolder  As String
    Dim sRootFolder As String
    
    
    
    ' Select target folder.
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    
    ' If user selected nothing, exit sub.
    If fd.Show = False Then Exit Sub
    
    ' Get root folder path.
    sRootFolder = fd.SelectedItems( 1 )
    
    ' Define mask.
    sMask = "Набор-*"
    
    ' Create new sub-folder. It will be located in the root folder.
    ' Create path to sub-folder.
    sSubFolder = sRootFolder & "\NewFiles"
    
    ' If sub-folder already exists, delete it.
    If fso.FolderExists(sSubFolder) Then fso.DeleteFolder sSubFolder, True
    
    ' Create sub-folder.
    fso.CreateFolder sSubFolder
    
    
    ' Process each and every file.
    For Each aFile In fso.GetFolder(sRootFolder).Files
        
        ' Get file extension.
        sExtension = fso.GetExtensionName(aFile.Name)
        
        ' If it's an Excel file, process it further.
        If sExtension Like "xls*" Then
            
            ' Get file name without extension.
            sFileName = fso.GetBaseName(aFile.Name)
            
            ' Check whether file name matches mask.
            If sFileName Like sMask Then
                
                ' Get number.
                ' InStrRev searches for "-" from right to left.
                sNumber = Right$(sFileName, Len(sFileName) - InStrRev(sFileName, "-"))
                
                ' Create new Excel file name.
                sNewName = "Итог-" & sNumber
                                
                ' Create full path to new Excel file.
                sFullPath = sSubFolder & "\" & sNewName & "." & sExtension
                
                ' Copy original file to sub-folder.
                aFile.Copy sFullPath
                
            End If
            
        End If
        
    Next
    
End Sub

Sub ReadTextFile()

    Dim msg As String
    Dim sFile As String
    Dim txtStream As TextStream
    Dim fso As New FileSystemObject
    
    sFile = "c:\shut down.txt"
    
    Set txtStream = fso.OpenTextFile(sFile, ForReading)
    
    msg = txtStream.ReadAll
    
    MsgBox msg

End Sub

Sub ReadTextFileLineByLine()

    Dim i As Integer
    Dim msg As String
    Dim sFile As String
    Dim sLine As Variant
    Dim arr As Variant
    Dim txtStream As TextStream
    Dim fso As New FileSystemObject
        
    sFile = "c:\shut down.txt"
    Set txtStream = fso.OpenTextFile(sFile, ForReading)
    arr = Split(txtStream.ReadAll, vbNewLine)

    For i = LBound(arr) To UBound(arr)
        msg = msg & arr(i) & vbNewLine
    Next
    
    MsgBox msg

End Sub

Dim parFullName As String
parFullName = aFile

For Each aFile In fso.GetFolder(sRootFolder).Files

parFullName = aFile.Name

Dim PagePar As Worksheet

Dim wkb As Workbook
Dim parFullName As String
Dim PagePar As Worksheet
....
For Each aFile In fso.GetFolder(sRootFolder).Files
...
    parFullName = aFile.Path
    Set wkb = Workbooks.Open(parFullName)
    Set PagePar = wkb.Sheets("Page1")
...
   ' После всех обработок:
   ' Всегда указывай параметр SaveChanges.
   ' Если ты не будешь ничего там сохранять - ставь False, иначе - True.
   wkb.Close SaveChanges:=False
   Set wkb = Nothing

Dim wkb As Workbook
Dim parFullName As String
Dim PagePar As Worksheet
....
For Each aFile In fso.GetFolder(sRootFolder).Files
...
    parFullName = aFile.Path
    Set wkb = Workbooks.Open(parFullName)
    Set PagePar = wkb.Sheets("Page1")

Dim parFullName As String
Dim PagePar As Worksheet
....
For Each aFile In fso.GetFolder(sRootFolder).Files
...
    parFullName = aFile.Path
    Set PagePar = Workbooks.Open(parFullName).Sheets("Page1")

Dim PagePar As Worksheet
....
For Each aFile In fso.GetFolder(sRootFolder).Files
...
    Set PagePar = Workbooks.Open(aFile.Path).Sheets("Page1")

For Each aFile In fso.GetFolder(sRootFolder).Files
...
    With Workbooks.Open(aFile.Path).Sheets("Page1")
    ...
    End With
...

Sub ForNextLoop()

    Dim i As Long
    
    For i =  1  To  100 
       ' Мы нашли, что ячейка непуста => содержит данные.
       ' Вместо Cells(i, "C") можно написать Cells(i, 3).
        If Not IsEmpty(Cells(i, "C")) Then
            ' Обработка.
        End If
    Next

End Sub

If Range("C1")=""...