Sub Выбрать()

Dim MyPath As String, iFileName As String 
 
MyPath = "Здесь путь твой\"
 
iFileName = Dir(MyPath)

 Do While iFileName <> ""
      If UCase(Right(iFileName,  3 )) = "XLS" Then
         msgbox iFileName
      End If
  iFileName = Dir
 Loop


End Sub

'Выбрать файлы XLS в каталоге и подкаталогах
Sub Запуск()
Dim fso As New FileSystemObject

' Запускаешь процедуру перебора книг в каталоге и подкаталогах с указанием пути
' в примере для 3-х каталогов, можно добавить строк скольеко нужно и изменить путь
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("Y:\!")
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("\\Ukdc\Common\СФД\Общая\!sad")
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("Y:\sad")
End Sub

'FileSystemObject - БИБЛИОТЕКА  Microsoft Scripting Runtime
Sub ВыбратьКаталогПодкаталогиFSO(Папка As Folder)
Dim fso As New FileSystemObject, fold As Folder, iFile As File

 For Each fold In Папка.SubFolders
   ВыбратьКаталогПодкаталогиFSO fold        'лезем в рекурсию
 Next
  
 For Each iFile In Папка.Files
   If UCase(Right(iFile,  3 )) = "XLS" Then
      ОбработчикФайла (iFile.Path)
   End If
 Next
End Sub

Sub ОбработчикФайла(pathFile As String)
Dim openWb  As Workbook
 Workbooks.Open pathFile, False
 Set openWb = ActiveWorkbook
 'Вместо строки MsgBox вставить любую обработку открытой книги openWb
 'Можно не открывать книгу а скопировать данные из закрытой книги, но об этом в следующий раз
  MsgBox "Имя открытой книги - " & openWb.Name
 
 openWb.Close False
End Sub

Dim svod As Workbook
Dim fso As New FileSystemObject

Sub Запуск()
' назначаем сводную книгу
Set svod = Workbooks("База.xls")
'очищаем сводный лист от старья
svod.Sheets("Лист1").Range("A10:BF65536").ClearContents
' Запускаешь процедуру перебора книг в каталоге и подкаталогах с указанием пути
' в примере для 3-х каталогов, можно добавить строк скольеко нужно и изменить путь
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("Y:\!")
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("\\Ukdc\Common\СФД\Общая\!sad")
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("Y:\sad")
End Sub

'Выбрать файлы XLS в каталоге и подкаталогах
'FileSystemObject - БИБЛИОТЕКА  Microsoft Scripting Runtime
Sub ВыбратьКаталогПодкаталогиFSO(Папка As Folder)
Dim fold As Folder, iFile As file

 For Each fold In Папка.SubFolders
   ВыбратьКаталогПодкаталогиFSO fold        'лезем в рекурсию
 Next
  
 For Each iFile In Папка.Files
   If UCase(Right(iFile,  3 )) = "XLS" Then
      ОбработчикФайла (iFile.path)
   End If
 Next
End Sub


Sub ОбработчикФайла(foolpathFile As String)

 Dim fname As String, fpath As String, sh As String
 Dim lastRow As Long
    ' имя исходного файла
    fname = Split(foolpathFile, "\")(UBound(Split(foolpathFile, "\")))
    ' путь к исходному файлу
    fpath = Left(foolpathFile, Len(foolpathFile) - Len(fname))
    ' Лист в исходных файлах
    sh = "Лист1"

    With svod.Sheets("Лист1")
     ' следующая после последней строка на сводном листе
     lastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Offset( 1 ).Row
     ' заполнение этой строки значениями из очередной книги
     ' слева указываешь столбцы из сводного листа
     ' справа указываешь адресс ячейки которую нужно перенести в данный столбец
        .Range("B" & lastRow).Value = GetCel(fpath, fname, sh, "A1")
        .Range("C" & lastRow).Value = GetCel(fpath, fname, sh, "A2")
        .Range("D" & lastRow).Value = GetCel(fpath, fname, sh, "A3")
        ' /// и т.д.
        
    End With
        
End Sub
' Функция получающая одну ячейку из закрытой книги
' Если возвращает #ССЫЛКА!, то скорее всего указанного листа в данной книге не существует
Private Function GetCel(fpath, fname, sh, rngStr)
  Dim formulaStr As String
    formulaStr = "'" & fpath & "[" & fname & "]" & sh & "'!" & Range(rngStr).Address(, , xlR1C1)
    Debug.Print formulaStr
    GetCel = ExecuteExcel4Macro(formulaStr)
End Function

    Debug.Print formulaStr

 For Each iFile In Папка.Files
   If UCase(iFile.Name) Like "ALG*.XLS" Then ОбработчикФайла (iFile.path)
 Next

   If UCase(iFile.Name) Like "ALG*.XLS" Then
     ОбработчикФайла (iFile.path)
     iFile.Name = "!" & iFile.Name
   End If

   If UCase(iFile.Name) Like "ALG*.XLS" Then
     ОбработчикФайла (iFile.path)
     iFile.Name = Format(GetCel(iFile.ParentFolder & "\", iFile.Name, "Лист1", "A1"), "yyyy.mm.dd") & iFile.Name
   End If

   If UCase(iFile.Name) Like "ALG*.XLS" Then
     ОбработчикФайла (iFile.path)
     iFile.Move "Y:\!База\"
   End If

lastRow = .Columns( 3 ).Resize(, .Columns.Count -  2 ).Find("*", , , , xlByRows, xlPrevious).Offset( 1 ).Row

Dim svod As Workbook
Dim fso As New FileSystemObject

Sub Запуск()
' назначаем сводную книгу
Set svod = Workbooks("База.xls")
'очищаем сводный лист от старья
svod.Sheets("Лист1").Range("C10:BF65536").ClearContents
' Запускаешь процедуру перебора книг в каталоге и подкаталогах с указанием пути
' в примере для 3-х каталогов, можно добавить строк скольеко нужно и изменить путь
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("C:\test\test1")
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("C:\test\test2")
 ''''''' и т.д.
End Sub

'Выбрать файлы XLS в каталоге и подкаталогах
'FileSystemObject - БИБЛИОТЕКА  Microsoft Scripting Runtime
Sub ВыбратьКаталогПодкаталогиFSO(Папка As Folder)
Dim fold As Folder, iFile As file

 For Each fold In Папка.SubFolders
   ВыбратьКаталогПодкаталогиFSO fold        'лезем в рекурсию
 Next
  
 For Each iFile In Папка.Files
   If UCase(iFile.Name) Like "ALG*.XLS" Then
     Call ОбработчикФайла(iFile.Path)
     Call RenameReplaceFile(iFile)
   End If
 Next
End Sub


Sub ОбработчикФайла(foolpathFile As String)

 Dim fname As String, fpath As String, sh As String
 Dim lastRow As Long
    ' имя исходного файла
    fname = Split(foolpathFile, "\")(UBound(Split(foolpathFile, "\")))
    ' путь к исходному файлу
    fpath = Left(foolpathFile, Len(foolpathFile) - Len(fname))
    ' Лист в исходных файлах
    sh = "Лист1"

    With svod.Sheets("Лист1")
     ' следующая после последней строка на сводном листе
     lastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Offset( 1 ).Row
     ' заполнение этой строки значениями из очередной книги
     ' слева указываешь столбцы из сводного листа
     ' справа указываешь адресс ячейки которую нужно перенести в данный столбец
        .Range("C" & lastRow).Value = GetCel(fpath, fname, sh, "A1")
        .Range("D" & lastRow).Value = GetCel(fpath, fname, sh, "A2")
        .Range("E" & lastRow).Value = GetCel(fpath, fname, sh, "A3")
        ' /// и т.д.
        
    End With
        
End Sub

Sub RenameReplaceFile(replaceFile As file)
 Dim n
 Dim pathForReplace As String
 Dim tipeFile As String, nameMinusTipe As String
  
  ' путь для перемещения файлов
  pathForReplace = "C:\test\Base\"
  ' расширение файла
  tipeFile = Split(replaceFile.Name, ".")(UBound(Split(replaceFile.Name, ".")))
  ' имя файла без расширения
  nameMinusTipe = Left(replaceFile.Name, Len(replaceFile.Name) - Len(tipeFile) -  1 )
   
  ' подпоб коэффициента для имени файла
  n = ""
  Do While Dir(pathForReplace & nameMinusTipe & n & "." & tipeFile) <> ""
   n = Val(n) +  1 
  Loop
    
  'переименование файла
  If Val(n) Then replaceFile.Name = nameMinusTipe & n & "." & tipeFile
  ' перемещение файла
  replaceFile.Move pathForReplace
        
End Sub
' Функция получающая одну ячейку из закрытой книги
' Если возвращает #ССЫЛКА!, то скорее всего указанного листа в данной книге не существует
Private Function GetCel(fpath, fname, sh, rngStr)
  Dim formulaStr As String
    formulaStr = "'" & fpath & "[" & fname & "]" & sh & "'!" & Range(rngStr).Address(, , xlR1C1)
    Debug.Print formulaStr
    GetCel = ExecuteExcel4Macro(formulaStr)
End Function

Dim svod As Workbook
Dim fso As New FileSystemObject

Sub Запуск()
' назначаем сводную книгу
Set svod = Workbooks("База.xls")
'очищаем сводный лист от старья
svod.Sheets("Лист1").Range("C10:BF65536").ClearContents
' Запускаешь процедуру перебора книг в каталоге и подкаталогах с указанием пути
' в примере для 3-х каталогов, можно добавить строк скольеко нужно и изменить путь
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("Y:\test\test1")
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("Y:\test\test2")
 ''''''' и т.д.
End Sub

'Выбрать файлы XLS в каталоге и подкаталогах
'FileSystemObject - БИБЛИОТЕКА  Microsoft Scripting Runtime
Sub ВыбратьКаталогПодкаталогиFSO(Папка As Folder)
Dim fold As Folder, iFile As file

 For Each fold In Папка.SubFolders
   ВыбратьКаталогПодкаталогиFSO fold        'лезем в рекурсию
 Next
  
 For Each iFile In Папка.Files
   If UCase(iFile.Name) Like "ALG*.XLS" Then
     Call ОбработчикФайла(iFile.Path)
     Call RenameReplaceFile(iFile)
   End If
 Next
End Sub


Sub ОбработчикФайла(foolpathFile As String)

 Dim fname As String, fpath As String, sh As String
 Dim lastRow As Long
    ' имя исходного файла
    fname = Split(foolpathFile, "\")(UBound(Split(foolpathFile, "\")))
    ' путь к исходному файлу
    fpath = Left(foolpathFile, Len(foolpathFile) - Len(fname))
    ' Лист в исходных файлах
    sh = "Лист1"

    With svod.Sheets("Лист1")
        ' следующая после последней строка на сводном листе
        lastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Offset( 1 ).Row
        ' заполнение этой строки значениями из очередной книги
        Call GetRange(fpath, fname, sh, "A1", .Range("C" & lastRow))
        Call GetRange(fpath, fname, sh, "A2", .Range("D" & lastRow))
        Call GetRange(fpath, fname, sh, "A3", .Range("E" & lastRow))
        ' /// и т.д.
    End With
        
End Sub

' Процедура, получающая диапазон из закрытой книги, можно сразу диапазоны доставать,
'  но при этом из исходного диаапазона будет скопирован диапазон такого же размра (по высоте и ширене)
' Если возвращает #ССЫЛКА!, то скорее всего указанного листа в данной книге не существует
Sub GetRange(FilePath As String, FileName As String, SheetName As String, _
SourceRange As String, DestRange As Range)
'Resize the DestRange to the same size as the SourceRange
Set DestRange = DestRange.Resize(Range(SourceRange).Rows.Count, _
                                 Range(SourceRange).Columns.Count)
'Add formula links to the closed file
With DestRange
  .FormulaArray = "='" & FilePath & "[" & FileName & "]" & SheetName & "'!" & SourceRange
  'Make values from the formulas
  .Value = .Value
End With
End Sub

Sub RenameReplaceFile(replaceFile As file)
 Dim n
 Dim pathForReplace As String
 Dim tipeFile As String, nameMinusTipe As String
  
  ' путь для перемещения файлов
  pathForReplace = "Y:\test\Base\"
  ' расширение файла
  tipeFile = Split(replaceFile.Name, ".")(UBound(Split(replaceFile.Name, ".")))
  ' имя файла без расширения
  nameMinusTipe = Left(replaceFile.Name, Len(replaceFile.Name) - Len(tipeFile) -  1 )
   
  ' подпоб коэффициента для имени файла
  n = ""
  Do While Dir(pathForReplace & nameMinusTipe & n & "." & tipeFile) <> ""
   n = Val(n) +  1 
  Loop
    
  'переименование файла
  If Val(n) Then replaceFile.Name = nameMinusTipe & n & "." & tipeFile
  ' перемещение файла
  replaceFile.Move pathForReplace
        
End Sub