Sub Найти_документы()
Const AddrresCell = 4
Dim p As String 'Директория файлов
Dim f As String 'Имя файла
Dim s As String 'Имя листа
Dim a As String 'Адрес ячейки
Dim Rng As Range, Sht As Worksheet
Dim i&, g&, h&, y&
Dim PName As String, FName As String, FQuant As Long, N As Long, d As String, WB As Workbook, firstAddress As String
Dim SkolkoNashol As Long
Dim SumFlag As Long
Dim TWB As Workbook
Set TWB = ThisWorkbook
'Вызываем диалоговое окно для определения папки с файлами
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Укажите папку, в которой находятся файлы"
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Отменено" 'Прекращение работы
Exit Sub
Else
PName = .SelectedItems(1) 'Получение пути
'Считаем количество файлов в папке для создания массива названий файлов
FName = Dir(PName & "\*.xls") 'Получаем имя первого файла
FQuant = 0 'обнуляем кол-во файлов
' Цикл подсчета кол-ва файлов
Do Until FName = "" 'Пока имя файла не станет пустым
FQuant = FQuant + 1 'Счетчик кол-ва
FName = Dir 'Получение следующего имени файла
Loop
'Заполняем массив названиями файлов
ReDim arr(1 To FQuant) As String 'Задание размерности массива на основе кол-ва файлов
FName = Dir(PName & "\*.xls") 'Получаем имя первого файла
N = 0 'обнуляем счетчик
' Цикл заполнения массива именами файлов
Do Until FName = "" 'Пока имя файла не станет пустым
N = N + 1 'Счетчик размерности массива
arr(N) = FName 'Заполнение ячейки массива
FName = Dir 'Получение следующего имени файла
Loop
N = 0
'Цикл перебора файлов
d = InputBox("Что ищем?")
If IsNull(d) Then Exit Sub
y = 1
For N = 1 To FQuant
SumFlag = 0
p = PName & "\" 'Директория файлов
f = arr(N) 'получаем имя файла
s = Left(arr(N), Len(arr(N)) - 5) 'получаем имя листа
'On Error Resume Next
Set WB = Workbooks.Open(p & f)
'Set WB = GetObject(p & f)
'Workbooks(f).Activate
For Each Sht In WB.Sheets 'цикл по всем листам в файле
Set Rng = Sht.Cells.Find(d, , xlFormulas, xlWhole) 'xlWhole - ячейка целиком, xlPart - часть ячейки
If Not Rng Is Nothing Then 'если нашли
SkolkoNashol = 1
firstAddress = Rng.Address 'запоминаем адрес первой найденной ячейки
i = y
Do
'MsgBox "Найдено на листе " & Rng.Parent.Name & " в ячейке " & Rng.Address(0, 0), vbInformation, "Конец"
g = Rng.Row
h = Rng.Column
'If Rng.Offset(0, 5).Value <> "Да" Or Rng.Offset(0, 5).Value <> "ДА" Then
'MsgBox "Значение ячейки " & Rng.Offset(0, 5).Value, vbInformation, "Конец"
'Exit Sub
'End If
'MsgBox "Найдено на листе " & Rng.Parent.Name & " в ячейке " & Rng.Address(0, 0), vbInformation, "Конец"
If Rng.Offset(0, 5).Value <> "Да" And Rng.Offset(0, 5).Value <> "ДА" And Rng.Offset(0, 5).Value <> "да" Then
If h = Range("D" & g).Column Then
SumFlag = 1
'MsgBox "Значение ячейки " & Rng.Offset(0, -3).Value, vbInformation, "Конец"
TWB.Sheets(1).Range("B" & i).Value = Rng.Offset(0, -3).Value
TWB.Sheets(1).Range("C" & i).Value = Rng.Offset(0, -1).Value
TWB.Sheets(1).Range("D" & i).Value = Rng.Offset(0, 2).Value
TWB.Sheets(1).Range("E" & i).Value = Rng.Offset(0, 3).Value
ElseIf h = Range("H" & g).Column Then
SumFlag = 1
TWB.Sheets(1).Range("B" & i).Value = Rng.Offset(0, -4).Value
TWB.Sheets(1).Range("C" & i).Value = Rng.Offset(0, 1).Value
TWB.Sheets(1).Range("D" & i).Value = Rng.Offset(0, 4).Value
TWB.Sheets(1).Range("E" & i).Value = Rng.Offset(0, 3).Value
End If
i = y + SkolkoNashol
SkolkoNashol = SkolkoNashol + 1
End If
Set Rng = Sht.Cells.FindNext(Rng) 'ищем следующую ячейку на листе
Loop Until firstAddress = Rng.Address 'повторяем цикл, пока не вернёмся к первой найденной ячейке
If SumFlag = 1 Then
y = y + SkolkoNashol
End If
End If
Next Sht
If Rng Is Nothing Then 'если не нашли
GoTo Metka
End If
Metka:
WB.Close
Next N
If Rng Is Nothing Then 'если не нашли
MsgBox "Не найдено ни на одном листе ни в одной книге!", vbExclamation, "Конец"
End If
End If
End With
End Sub |