Hello, MAXMAN
Could you upload the PDF file which can't get the correct number here? Or you can send your PDF file to my email: .
So that we can check the problem.
Thank you!

Hi, John, To count the pages of .doc and .docx as well as the PDF files, please apply the following code:<div data-tag="code">Sub StatisticsPage()
Dim I As Long
Dim xRg As Range
Dim xStr As String
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim xFileNum As Long
Dim RegExp As Object
Dim xWdApp
Dim xWd
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
Application.ScreenUpdating = False
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.pdf", vbDirectory)
Set xRg = Range("A1")
Range("A:B").ClearContents
Range("A1:B1").Font.Bold = True
xRg = "File Name"
xRg.Offset(0, 1) = "Pages"
I = 2
xStr = ""
Do While xFileName <> ""
Cells(I, 1) = xFileName
Set RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Type\s*/Page[^s]"
xFileNum = FreeFile
Open (xFdItem & xFileName) For Binary As #xFileNum
xStr = Space(LOF(xFileNum))
Get #xFileNum, , xStr
Close #xFileNum
Cells(I, 2) = RegExp.Execute(xStr).Count
I = I + 1
xFileName = Dir
Loop
xFileName = Dir(xFdItem & "*.docx", vbDirectory)
Set xWdApp = CreateObject("Word.Application")
Do While xFileName <> ""
Cells(I, 1) = xFileName
xFileNum = FreeFile
Set xWd = GetObject(xFdItem & xFileName)
Cells(I, 2) = xWd.ActiveWindow.Panes(1).Pages.Count
xWd.Close False
I = I + 1
xFileName = Dir
Loop
xFileName = Dir(xFdItem & "*.doc", vbDirectory)
Set xWdApp = CreateObject("Word.Application")
Do While xFileName <> ""
Cells(I, 1) = xFileName
xFileNum = FreeFile
Set xWd = GetObject(xFdItem & xFileName)
Cells(I, 2) = xWd.ActiveWindow.Panes(1).Pages.Count
xWd.Close False
I = I + 1
xFileName = Dir
Loop
Columns("A:B").AutoFit
End If
Application.ScreenUpdating = True
End SubPlease try, hope it can help you!

Hi, i have a folder with multiple subfolders  How can i specify the parent folder Path without manually selecting it. Then also the output the name of the child folder. Thanks in advance 

HI sorted i have edited the code removed XFD and set filpath as xfditem

Hi, sroczeto,
To count the page number of .doc and .docx as well as the PDF files, please apply the following code:
Sub Test()
Dim I As Long
Dim xRg As Range
Dim xStr As String
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim xFileNum As Long
Dim RegExp As Object
Dim xWdApp
Dim xWd
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
Application.ScreenUpdating = False
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.pdf", vbDirectory)
Set xRg = Range("A1")
Range("A:B").ClearContents
Range("A1:B1").Font.Bold = True
xRg = "File Name"
xRg.Offset(0, 1) = "Pages"
I = 2
xStr = ""
Do While xFileName <> ""
Cells(I, 1) = xFileName
Set RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Type\s*/Page[^s]"
xFileNum = FreeFile
Open (xFdItem & xFileName) For Binary As #xFileNum
xStr = Space(LOF(xFileNum))
Get #xFileNum, , xStr
Close #xFileNum
Cells(I, 2) = RegExp.Execute(xStr).Count
I = I + 1
xFileName = Dir
Loop
xFileName = Dir(xFdItem & "*.docx", vbDirectory)
Set xWdApp = CreateObject("Word.Application")
Do While xFileName <> ""
Cells(I, 1) = xFileName
xFileNum = FreeFile
Set xWd = GetObject(xFdItem & xFileName)
Cells(I, 2) = xWd.ActiveWindow.Panes(1).Pages.Count
xWd.Close False
I = I + 1
xFileName = Dir
Loop
Columns("A:B").AutoFit
End If
Application.ScreenUpdating = True
End Sub

Thanks mate! It works on pdf and docx, but not on doc files. And one question more, can yo uadd that this will count in subfolders too?

Hello, Flavio,
To get the number of all the PDF files from folder and subfolders, please apply the below code:

Sub Test()
Dim I As Long
Dim xRg As Range
Dim xStr As String
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim xFileNum As Long
Dim RegExp As Object
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
Set xRg = Range("A1")
Range("A:B").ClearContents
Range("A1:B1").Font.Bold = True
xRg = "File Name"
xRg.Offset(0, 1) = "Pages"
I = 2
Call SunTest(xFdItem, I)
End If
End Sub

Sub SunTest(xFdItem As Variant, I As Long)
Dim xRg As Range
Dim xStr As String
Dim xFd As FileDialog
Dim xFileName As String
Dim xFileNum As Long
Dim RegExp As Object
Dim xF As Object
Dim xSF As Object
Dim xFso As Object
xFileName = Dir(xFdItem & "*.pdf", vbDirectory)
xStr = ""
Do While xFileName <> ""
Cells(I, 1) = xFileName
Set RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Type\s*/Page[^s]"
xFileNum = FreeFile
Open (xFdItem & xFileName) For Binary As #xFileNum
xStr = Space(LOF(xFileNum))
Get #xFileNum, , xStr
Close #xFileNum
Cells(I, 2) = RegExp.Execute(xStr).Count
I = I + 1
xFileName = Dir
Loop
Columns("A:B").AutoFit
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xF = xFso.GetFolder(xFdItem)
For Each xSF In xF.SubFolders
Call SunTest(xSF.Path & "\", I)
Next
End Sub

Please try, hope it can help you!

Hello, SrdosPDF
The following VBA code may do you a favor, please try it:

Sub Test()
Dim I As Long
Dim xRg As Range
Dim xStr As String
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim xFileNum As Long
Dim RegExp As Object
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
Set xRg = Range("A1")
Range("A:B").ClearContents
Range("A1:B1").Font.Bold = True
xRg = "File Name"
xRg.Offset(0, 1) = "Pages"
xRg.Offset(0, 2) = "Size(b)"
I = 2
Call SunTest(xFdItem, I)
End If
End Sub

Sub SunTest(xFdItem As Variant, I As Long)
Dim xRg As Range
Dim xStr As String
Dim xFd As FileDialog
Dim xFileName As String
Dim xFileNum As Long
Dim RegExp As Object
Dim xF As Object
Dim xSF As Object
Dim xFso As Object
xFileName = Dir(xFdItem & "*.pdf", vbDirectory)
xStr = ""
Do While xFileName <> ""
Cells(I, 1) = xFileName
Set RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Type\s*/Page[^s]"
xFileNum = FreeFile
Open (xFdItem & xFileName) For Binary As #xFileNum
xStr = Space(LOF(xFileNum))
Get #xFileNum, , xStr
Close #xFileNum
Cells(I, 2) = RegExp.Execute(xStr).Count
Cells(I, 3) = FileLen(xFdItem & xFileName)
I = I + 1
xFileName = Dir
Loop
Columns("A:B").AutoFit
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xF = xFso.GetFolder(xFdItem)
For Each xSF In xF.SubFolders
Call SunTest(xSF.Path & "\", I)
Next
End Sub

Hope this can help you!

Hello, Flavio,
You can upload your PDF file here, so we can check the problem.
Thank you!

Hello, Daphne,
For solving your problem, please apply the below code, please try, hope it can help you!

Sub Test()
Dim I As Long
Dim xRg As Range
Dim xStr As String
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim xFileNum As Long
Dim RegExp As Object
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
Set xRg = Range("A1")
Range("A:B").ClearContents
Range("A1:B1").Font.Bold = True
xRg = "File Name"
xRg.Offset(0, 1) = "Pages"
xRg.Offset(0, 2) = "Path"
xRg.Offset(0, 3) = "Size(b)"
I = 2
Call SunTest(xFdItem, I)
End If
End Sub

Sub SunTest(xFdItem As Variant, I As Long)
Dim xRg As Range
Dim xStr As String
Dim xFd As FileDialog
Dim xFileName As String
Dim xFileNum As Long
Dim RegExp As Object
Dim xF As Object
Dim xSF As Object
Dim xFso As Object
xFileName = Dir(xFdItem & "*.pdf", vbDirectory)
xStr = ""
Do While xFileName <> ""
Cells(I, 1) = xFileName
Set RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Type\s*/Page[^s]"
xFileNum = FreeFile
Open (xFdItem & xFileName) For Binary As #xFileNum
xStr = Space(LOF(xFileNum))
Get #xFileNum, , xStr
Close #xFileNum
Cells(I, 2) = RegExp.Execute(xStr).Count
Cells(I, 3) = xFdItem & xFileName
Cells(I, 4) = FileLen(xFdItem & xFileName)
I = I + 1
xFileName = Dir
Loop
Columns("A:B").AutoFit
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xF = xFso.GetFolder(xFdItem)
For Each xSF In xF.SubFolders
Call SunTest(xSF.Path & "\", I)
Next
End Sub

Hi skyyang,
Sorry to bump an old post.
Thank you for the above code, it is helping me so much!
Would you by kind enough to share how to add the 'file create date' also where the format is only the date, no time included, DD/MMM/YYYY?
No matter where I search, I cannot seem to edit your code to do this correctly myself..

Thank you in advance!

Ray

Hello, Prashant,
To get the number of all the PDF files from folder and subfolders, please apply the below code:

Sub Test()
Dim I As Long
Dim xRg As Range
Dim xStr As String
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim xFileNum As Long
Dim RegExp As Object
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
Set xRg = Range("A1")
Range("A:B").ClearContents
Range("A1:B1").Font.Bold = True
xRg = "File Name"
xRg.Offset(0, 1) = "Pages"
I = 2
Call SunTest(xFdItem, I)
End If
End Sub

Sub SunTest(xFdItem As Variant, I As Long)
Dim xRg As Range
Dim xStr As String
Dim xFd As FileDialog
Dim xFileName As String
Dim xFileNum As Long
Dim RegExp As Object
Dim xF As Object
Dim xSF As Object
Dim xFso As Object
xFileName = Dir(xFdItem & "*.pdf", vbDirectory)
xStr = ""
Do While xFileName <> ""
Cells(I, 1) = xFileName
Set RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Type\s*/Page[^s]"
xFileNum = FreeFile
Open (xFdItem & xFileName) For Binary As #xFileNum
xStr = Space(LOF(xFileNum))
Get #xFileNum, , xStr
Close #xFileNum
Cells(I, 2) = RegExp.Execute(xStr).Count
I = I + 1
xFileName = Dir
Loop
Columns("A:B").AutoFit
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xF = xFso.GetFolder(xFdItem)
For Each xSF In xF.SubFolders
Call SunTest(xSF.Path & "\", I)
Next
End Sub

Please try, hope it can help you!

Here is the code I found somewhere on the net, it's not as optimal as your method:
Option Explicit
Public PDFDoc As AcroPDDoc, PDFPage As Object, A3&, A4&

Sub Main()
Dim fso As FileSystemObject, fld As Folder, fil As File, s$, i&, Arr()
Set fso = New FileSystemObject
Set PDFDoc = New AcroPDDoc
Set fld = fso.GetFolder(ThisWorkbook.Path)
ReDim Arr(1 To 1000, 1 To 3)
For Each fil In fld.Files
s = fil.Name
If Right(s, 4) = ".pdf" Then
CountPagesPDF (ThisWorkbook.Path & "\" & s)
i = i + 1
Arr(i, 1) = s
Arr(i, 2) = A3
Arr(i, 3) = A4
End If
Next
Range("A2:C" & Cells.Rows.Count).Clear
Range("A2:C" & (i + 1)) = Arr
Set PDFPage = Nothing
Set PDFDoc = Nothing
Set fso = Nothing
End Sub

Sub CountPagesPDF(FullFileName$)
Dim i&, n&, x, y
A3 = 0
A4 = 0
PDFDoc.Open (FullFileName)
n = PDFDoc.GetNumPages
For i = 0 To n - 1
Set PDFPage = PDFDoc.AcquirePage(i)
x = PDFPage.GetSize().x
y = PDFPage.GetSize().y
If x + y > 1500 Then A3 = A3 + 1 Else A4 = A4 + 1
Next
PDFDoc.Close
End Sub

Thanks you very much.
Likewise, can you count and categorize A3 and A4 pages?

Hello,
You are welcome. Glad it helps. Any questions, please feel free to contact us. Have a great day.
Sincerely,
Mandy