Сбор даных с разных книг в одну

[Pao]

Ув. Hugo121 полазил в гугле и немного модифицировал код вот что получилось:
Sub export()
Dim FSO
Dim TheFolder, TheFiles, AFile
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set FSO = CreateObject("Scripting.FileSystemO bject")
Set TheFolder = FSO.GetFolder("F:\export\20100627\" )
Set TheFiles = TheFolder.Files
For Each AFile In TheFiles
If UCase(FSO.GetExtensionName(AFile.Pa th)) = "XLS" Then
Set xls = Workbooks.Open(Filename:=AFile, ReadOnly:=True)

dt = Format([General_TODATE], "dd")
dm = Format([General_TODATE], "mm")
zaccol = dt * 2
iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
terminal = Cells(iLastRow - 1, 5)
zac = Cells(iLastRow, 13)
com = Cells(iLastRow, 12)

Set x = ThisWorkbook.Sheets(dm).Columns(1). Find(terminal, , , , xlWhole)
ThisWorkbook.Sheets(dm).Cells(x.Row , zaccol).Value = zac
ThisWorkbook.Sheets(dm).Cells(x.Row + 1, zaccol + 1).Value = com

xls.Close False
End If
Next
Application.ScreenUpdating = True
End Sub

Теперь он осуществляет перебор всех файлов из папки и заносит данные сразу в таблицу. Хотелось бы узнать можноли как нибудь сделать чтоб он еще и подпапки проверял, и как нибудь его ограницить чтоб он не все файлы xls открывал а только с определенными названиями т.к. в этих папках не только данные по терминалам а также еще и по получателям и общие данные?

[doober]

Процедура поиска файлов во всех вложеных папках

Dim sl
 Sub Main()
  
    Set fso = CreateObject("Scripting.FileSystemObject")
 PrintChilds fso.GetFolder("F:\")
      
rr = Split(sl, Chr(10), -1)
   Set fso = Nothing  
End Sub
Private Sub PrintChilds(ff)
  On Error Resume Next

    For Each fo In ff.SubFolders
       
         
         Dim s As String
    s = Dir(fo.Path & "\*.xls")
 
    Do While s <> ""
      sl = sl & fo.Path & "\" & s & Chr(10)
    
        s = Dir
    
    Loop

        PrintChilds fo
    Next fo
       
End Sub

[Pao]

А как этот код связать с моим? Я мало понимаю в этих кодах.

[Hugo121]

С помощью doober попробуйте такую сборку (лишнее от прежнего кода пока закомментировал через REM, потом можно убрать).

Dim sl
Sub export()
Dim FSO
Rem Dim TheFolder, TheFiles, AFile
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set FSO = CreateObject("Scripting.FileSystemObject")
Rem Set TheFolder = FSO.GetFolder("F:\export\20100627\" )
Rem Set TheFiles = TheFolder.Files
Rem For Each AFile In TheFiles

PrintChilds FSO.GetFolder("F:\export\20100627\")
rr = Split(sl, Chr(10), -1)
Set FSO = Nothing

Rem If UCase(FSO.GetExtensionName(AFile.Path)) = "XLS" Then
For i = LBound(rr) To UBound(rr)
Set xls = Workbooks.Open(Filename:=rr(i), ReadOnly:=True)

dt = Format([General_TODATE], "dd")
dm = Format([General_TODATE], "mm")
zaccol = dt * 2
iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
terminal = Cells(iLastRow - 1, 5)
zac = Cells(iLastRow, 13)
com = Cells(iLastRow, 12)

Set x = ThisWorkbook.Sheets(dm).Columns(1).Find(terminal, , , , xlWhole)
ThisWorkbook.Sheets(dm).Cells(x.Row, zaccol).Value = zac
ThisWorkbook.Sheets(dm).Cells(x.Row + 1, zaccol + 1).Value = com

xls.Close False
Next i
Rem End If

Rem Next
Application.ScreenUpdating = True
End Sub


Private Sub PrintChilds(ff)
  On Error Resume Next

    For Each fo In ff.SubFolders
         
    Dim s As String
    s = Dir(fo.Path & "\*.xls")
 
    Do While s <> ""
    If InStr(s, "слово_которое_должно_быть_в_названии_файла") Then
      sl = sl & fo.Path & "\" & s & Chr(10)
    End If
    s = Dir
    
    Loop

        PrintChilds fo
    Next fo
       
End Sub

Вместо "слово_которое_должно_быть_в_назван ии_файла" попробуйте "ДействительныеПлатежиНаличными ".
Возможно, тут надо как-то иначе придумать отбор нужных файлов, нам пока эти критерии не известны
Поясню процесс - в процедуре PrintChilds(ff) в строку sl собираются полные имена всех нужных файлов, затем их перекладываем в массив rr (опять в основном коде), затем перебираем массив.

P.S. Добавил в начало Dim sl - как-то отвалилось....

[Pao]

Огромное спасибо, все работает.
И последний вопрос какую строку надо добавить чтоб если имена терменалов не совподает он просто пропускал его?

[Hugo121]

Так ведь было сделано, зачем убрали?

Set x = ThisWorkbook.Sheets(dm).Columns(1).Find(terminal, , , , xlWhole)
If Not x Is Nothing Then
ThisWorkbook.Sheets(dm).Cells(x.Row, zaccol).Value = zac
ThisWorkbook.Sheets(dm).Cells(x.Row + 1, zaccol + 1).Value = com
End If

Ключевое - условие If Not x Is Nothing Then

[Pao]

Если есть эта строка тогда выдает ошибку и выделяет next
xls.Close False
Next i
Rem End If

[Hugo121]

Вероятно, Вы забыли закрыть условие If ... Then... End If
Посмотрите внимательнее, не должно там быть ошибки.

[Pao]

Нашел ошибку действительно забыл закрыть условие.
Огромное Спасибо все работает как надо.