Option Explicit
Private Function GetValue(path, file, sheet, ref)
Dim arg As String
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "Файл не найден"
Exit Function
End If
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
GetValue = ExecuteExcel4Macro(arg)
End Function
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 'цикл по всем листам в файле
Sht.PageSetup.LeftHeader = ""
Sht.PageSetup.CenterHeader = ""
Sht.PageSetup.RightHeader = ""
Sht.PageSetup.LeftFooter = ""
Sht.PageSetup.CenterFooter = ""
Sht.PageSetup.RightFooter = ""
Sht.PageSetup.LeftMargin = Application.InchesToPoints(0.393700787401575)
Sht.PageSetup.RightMargin = Application.InchesToPoints(0.393700787401575)
Sht.PageSetup.TopMargin = Application.InchesToPoints(0.393700787401575)
Sht.PageSetup.BottomMargin = Application.InchesToPoints(0.393700787401575)
Sht.PageSetup.HeaderMargin = Application.InchesToPoints(0)
Sht.PageSetup.FooterMargin = Application.InchesToPoints(0)
Sht.PageSetup.PrintHeadings = False
Sht.PageSetup.PrintGridlines = False
Sht.PageSetup.PrintComments = xlPrintNoComments
Sht.PageSetup.PrintQuality = 600
Sht.PageSetup.CenterHorizontally = False
Sht.PageSetup.CenterVertically = False
Sht.PageSetup.Orientation = xlPortrait
Sht.PageSetup.Draft = False
Sht.PageSetup.PaperSize = xlPaperA4
Sht.PageSetup.FirstPageNumber = xlAutomatic
Sht.PageSetup.Order = xlOverThenDown
Sht.PageSetup.BlackAndWhite = False
Sht.PageSetup.Zoom = False
Sht.PageSetup.FitToPagesWide = 1
Sht.PageSetup.FitToPagesTall = False
Sht.PageSetup.PrintErrors = xlPrintErrorsDisplayed
Sht.PageSetup.OddAndEvenPagesHeaderFooter = False
Sht.PageSetup.DifferentFirstPageHeaderFooter = False
Sht.PageSetup.ScaleWithDocHeaderFooter = True
Sht.PageSetup.AlignMarginsHeaderFooter = False
Sht.PageSetup.EvenPage.LeftHeader.Text = ""
Sht.PageSetup.EvenPage.CenterHeader.Text = ""
Sht.PageSetup.EvenPage.RightHeader.Text = ""
Sht.PageSetup.EvenPage.LeftFooter.Text = ""
Sht.PageSetup.EvenPage.CenterFooter.Text = ""
Sht.PageSetup.EvenPage.RightFooter.Text = ""
Sht.PageSetup.FirstPage.LeftHeader.Text = ""
Sht.PageSetup.FirstPage.CenterHeader.Text = ""
Sht.PageSetup.FirstPage.RightHeader.Text = ""
Sht.PageSetup.FirstPage.LeftFooter.Text = ""
Sht.PageSetup.FirstPage.CenterFooter.Text = ""
Sht.PageSetup.FirstPage.RightFooter.Text = ""
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

=СЧЁТЕСЛИ(K18:K3503)