Количество листов в нескольких файлах

Sub ListSheetCounts()

Dim Cell        As Range

Dim Conn        As Object

Dim Cat         As Object

Dim ConnStr     As String

Dim n           As Long

Dim Rng         As Range

Dim RngEnd      As Range

Dim WkbPath     As Variant

Dim Wks         As Worksheet



' Folder path where the workbooks are located.

WkbPath = "C:\Users\Test"



' Name of worksheet with the workbook list.

Set Wks = Worksheets("Sheet1")



' Starting cell of workbook list.

Set Rng = Wks.Range("A2")



' Get the range of cells in the workbook name list.

Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)

If RngEnd.Row >= Rng.Row Then Set Rng = Wks.Range(Rng, RngEnd)



' Create the needed ADO objects fro this macro.

Set Conn = CreateObject("ADODB.Connection")

Set Cat = CreateObject("ADOX.Catalog")



' Add a final backslash the path if needed.

WkbPath = IIf(Right(WkbPath, 1) <> "\", WkbPath & "\", WkbPath)



' Step through each cell in the workbook list.

For Each Cell In Rng



' Get the worksheet count for the workbook.

ConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _

& WkbPath & Cell _

& ";Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1;"""

Conn.Open ConnStr



Set Cat.ActiveConnection = Conn



' Copy the count to the cell one column to right of the workbook name in the list.

Cell.Offset(n, 1) = Cat.Tables.Count



Conn.Close



Next Cell



' Clean up.

Set Cat = Nothing

Set Conn = Nothing

End Sub