Ahoj Fawazi,
Kód funguje dobře v mém Excelu, kterou verzi Excelu používáte?
Nebo můžete poslat svůj podrobný problém nebo soubory PDF na můj e-mail: skyyang@extendoffice. Com.

Dobrý den, Venkatesh G
Kód funguje dobře v mém Excelu, pošlete prosím své pdf soubory na můj e-mail: yy@addin99.com.
Abychom mohli zkontrolovat, kde je problém, děkujeme!

Dobrý den, Prashante,
Chcete-li získat počet všech souborů PDF ze složky a podsložek, použijte níže uvedený kód:

Sub Test ()
Dim I As Long
Dim xRg jako rozsah
Dim xStr jako řetězec
Dim xFd As FileDialog
Dim xFdItem jako varianta
Dim xFileName jako řetězec
Dim xFileNum as Long
Ztlumit RegExp jako objekt
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
Pokud xFd.Show = -1 Pak
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
Nastavit xRg = Range("A1")
Rozsah("A:B").Vymazat obsah
Rozsah("A1:B1").Font.Tučné = True
xRg = "Název souboru"
xRg.Offset(0, 1) = "Stránky"
I = 2 XNUMX
Zavolejte SunTest (xFdItem, I)
End If
End Sub

Sub SunTest (xFdItem As Variant, I As Long)
Dim xRg jako rozsah
Dim xStr jako řetězec
Dim xFd As FileDialog
Dim xFileName jako řetězec
Dim xFileNum as Long
Ztlumit RegExp jako objekt
Dim xF jako objekt
Dim xSF jako objekt
Dim xFso jako objekt
xFileName = Dir(xFdItem & "*.pdf", vbDirectory)
xStr = ""
Proveďte při xFileName <> ""
Cells(I, 1) = xFileName
Nastavit RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Typ\s*/Stránka[^s]"
xFileNum = FreeFile
Otevřít (xFdItem & xFileName) pro binární jako #xFileNum
xStr = mezera(LOF(xFileNum))
Získejte #xFileNum, , xStr
Zavřete #xFileNum
Cells(I, 2) = RegExp.Execute(xStr).Count
I = I + 1
xFileName = Dir
Smyčka
Columns("A:B").Automatické přizpůsobení
Set xFso = CreateObject("Scripting.FileSystemObject")
Nastavit xF = xFso.GetFolder(xFdItem)
Pro každý xSF v xF.SubFolders
Zavolejte SunTest(xSF.Path & "\", I)
další
End Sub

Zkuste to prosím, doufám, že vám to pomůže!

Můžete mi pomoci získat také tvůrce a rozměry souboru?

Ahoj,
Nemáš zač. Jsem rád, že to pomáhá. V případě jakýchkoli dotazů nás neváhejte kontaktovat. Přeji krásný den.
S pozdravem,
Mandy

Díky moc.
Stejně tak umíte počítat a kategorizovat stránky A3 a A4?

Zde je kód, který jsem našel někde na netu, není tak optimální jako vaše metoda:
Možnost explicitní
Veřejný PDFDoc jako AcroPDDoc, PDFPage jako objekt, A3&, A4&

Sub Main ()
Dim fso As FileSystemObject, fld As Folder, fil As File, s$, i&, Arr()
Nastavit fso = New FileSystemObject
Nastavit PDFDoc = Nový AcroPDDoc
Nastavit fld = fso.GetFolder(ThisWorkbook.Path)
ReDim Arr (1 až 1000, 1 až 3)
Pro každý fil In fld.Files
s = fil.Jméno
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
další
Rozsah("A2:C" & Cells.Rows.Count).Vymazat
Rozsah("A2:C" & (i + 1)) = Arr
Nastavit PDFPage = nic
Nastavit PDFDoc = Nic
Nastavit fso = nic
End Sub

Sub CountPagesPDF(FullFileName$)
Dim i&, n&, x, y
A3 = 0
A4 = 0
PDFDoc.Open (FullFileName)
n = PDFDoc.GetNumPages
Pro i = 0 až n - 1
Nastavit PDFPage = PDFDoc.AcquirePage(i)
x = PDFPage.GetSize().x
y = PDFPage.GetSize().y
Pokud x + y > 1500, pak A3 = A3 + 1 Jinak A4 = A4 + 1
další
PDFDoc.Zavřít
End Sub

Dobrý den, Daphne,
Chcete-li vyřešit svůj problém, použijte níže uvedený kód, zkuste to, doufám, že vám může pomoci!

Sub Test ()
Dim I As Long
Dim xRg jako rozsah
Dim xStr jako řetězec
Dim xFd As FileDialog
Dim xFdItem jako varianta
Dim xFileName jako řetězec
Dim xFileNum as Long
Ztlumit RegExp jako objekt
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
Pokud xFd.Show = -1 Pak
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
Nastavit xRg = Range("A1")
Rozsah("A:B").Vymazat obsah
Rozsah("A1:B1").Font.Tučné = True
xRg = "Název souboru"
xRg.Offset(0, 1) = "Stránky"
xRg.Offset(0, 2) = "Cesta"
xRg.Offset(0, 3) = "Velikost(b)"
I = 2 XNUMX
Zavolejte SunTest (xFdItem, I)
End If
End Sub

Sub SunTest (xFdItem As Variant, I As Long)
Dim xRg jako rozsah
Dim xStr jako řetězec
Dim xFd As FileDialog
Dim xFileName jako řetězec
Dim xFileNum as Long
Ztlumit RegExp jako objekt
Dim xF jako objekt
Dim xSF jako objekt
Dim xFso jako objekt
xFileName = Dir(xFdItem & "*.pdf", vbDirectory)
xStr = ""
Proveďte při xFileName <> ""
Cells(I, 1) = xFileName
Nastavit RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Typ\s*/Stránka[^s]"
xFileNum = FreeFile
Otevřít (xFdItem & xFileName) pro binární jako #xFileNum
xStr = mezera(LOF(xFileNum))
Získejte #xFileNum, , xStr
Zavřete #xFileNum
Cells(I, 2) = RegExp.Execute(xStr).Count
Cells(I, 3) = xFdItem & xFileName
Cells(I, 4) = FileLen(xFdItem & xFileName)
I = I + 1
xFileName = Dir
Smyčka
Columns("A:B").Automatické přizpůsobení
Set xFso = CreateObject("Scripting.FileSystemObject")
Nastavit xF = xFso.GetFolder(xFdItem)
Pro každý xSF v xF.SubFolders
Zavolejte SunTest(xSF.Path & "\", I)
další
End Sub

Ahoj skyyang,
Omlouvám se, že jsem narazil na starý příspěvek.
Děkuji za výše uvedený kód, moc mi pomáhá!
Chtěli byste se podělit o to, jak přidat „datum vytvoření souboru“ také tam, kde je formát pouze datum, bez času, DD/MMM/RRRR?
Bez ohledu na to, kde hledám, nedokážu upravit váš kód, abych to udělal správně.

Děkuji předem!

Paprsek

Dobrý den, Flavio,
Chcete-li získat počet všech souborů PDF ze složky a podsložek, použijte níže uvedený kód:

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

Zkuste to prosím, doufám, že vám to pomůže!

Dobrý den, Flavio,
Zde můžete nahrát svůj soubor PDF, abychom mohli problém zkontrolovat.
Děkuji!

Dobrý den, SrdosPDF
Následující kód VBA vám může udělat laskavost, zkuste to:

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

Doufám, že vám to může pomoci!

Ahoj sroczeto,
Chcete-li spočítat číslo stránek .doc a .docx a také souborů PDF, použijte následující kód:
Sub Test ()
Dim I As Long
Dim xRg jako rozsah
Dim xStr jako řetězec
Dim xFd As FileDialog
Dim xFdItem jako varianta
Dim xFileName jako řetězec
Dim xFileNum as Long
Ztlumit RegExp jako objekt
Ztlumit xWdApp
Rozměr xWd
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
Pokud xFd.Show = -1 Pak
Application.ScreenUpdating = False
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.pdf", vbDirectory)
Nastavit xRg = Range("A1")
Rozsah("A:B").Vymazat obsah
Rozsah("A1:B1").Font.Tučné = True
xRg = "Název souboru"
xRg.Offset(0, 1) = "Stránky"
I = 2 XNUMX
xStr = ""
Proveďte při xFileName <> ""
Cells(I, 1) = xFileName
Nastavit RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Typ\s*/Stránka[^s]"
xFileNum = FreeFile
Otevřít (xFdItem & xFileName) pro binární jako #xFileNum
xStr = mezera(LOF(xFileNum))
Získejte #xFileNum, , xStr
Zavřete #xFileNum
Cells(I, 2) = RegExp.Execute(xStr).Count
I = I + 1
xFileName = Dir
Smyčka
xFileName = Dir(xFdItem & "*.docx", vbDirectory)
Nastavit xWdApp = CreateObject("Word.Application")
Proveďte při xFileName <> ""
Cells(I, 1) = xFileName
xFileNum = FreeFile
Nastavit xWd = GetObject(xFdItem & xFileName)
Cells(I, 2) = xWd.ActiveWindow.Panes(1).Pages.Count
xWd.Close False
I = I + 1
xFileName = Dir
Smyčka
Columns("A:B").Automatické přizpůsobení
End If
Application.ScreenUpdating = True
End Sub

Díky kámo! Funguje na pdf a docx, ale ne na souborech doc. A ještě jedna otázka, můžete přidat, že se to bude počítat i do podsložek?

Ahoj, Johne, Chcete-li počítat stránky .doc a .docx a také soubory PDF, použijte prosím následující kód: Dílčí stránka statistik()
Dim I As Long
Dim xRg jako rozsah
Dim xStr jako řetězec
Dim xFd As FileDialog
Dim xFdItem jako varianta
Dim xFileName jako řetězec
Dim xFileNum as Long
Ztlumit RegExp jako objekt
Ztlumit xWdApp
Rozměr xWd
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
Pokud xFd.Show = -1 Pak
Application.ScreenUpdating = False
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.pdf", vbDirectory)
Nastavit xRg = Range("A1")
Rozsah("A:B").Vymazat obsah
Rozsah("A1:B1").Font.Tučné = True
xRg = "Název souboru"
xRg.Offset(0, 1) = "Stránky"
I = 2 XNUMX
xStr = ""
Proveďte při xFileName <> ""
Cells(I, 1) = xFileName
Nastavit RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Typ\s*/Stránka[^s]"
xFileNum = FreeFile
Otevřít (xFdItem & xFileName) pro binární jako #xFileNum
xStr = mezera(LOF(xFileNum))
Získejte #xFileNum, , xStr
Zavřete #xFileNum
Cells(I, 2) = RegExp.Execute(xStr).Count
I = I + 1
xFileName = Dir
Smyčka
xFileName = Dir(xFdItem & "*.docx", vbDirectory)
Nastavit xWdApp = CreateObject("Word.Application")
Proveďte při xFileName <> ""
Cells(I, 1) = xFileName
xFileNum = FreeFile
Nastavit xWd = GetObject(xFdItem & xFileName)
Cells(I, 2) = xWd.ActiveWindow.Panes(1).Pages.Count
xWd.Close False
I = I + 1
xFileName = Dir
Smyčka
xFileName = Dir(xFdItem & "*.doc", vbDirectory)
Nastavit xWdApp = CreateObject("Word.Application")
Proveďte při xFileName <> ""
Cells(I, 1) = xFileName
xFileNum = FreeFile
Nastavit xWd = GetObject(xFdItem & xFileName)
Cells(I, 2) = xWd.ActiveWindow.Panes(1).Pages.Count
xWd.Close False
I = I + 1
xFileName = Dir
Smyčka
Columns("A:B").Automatické přizpůsobení
End If
Application.ScreenUpdating = True
End SubProsím, zkuste to, doufám, že vám to pomůže!

Ahoj, mám složku s více podsložkami Jak mohu zadat cestu k nadřazené složce, aniž bych ji ručně vybral. Potom také výstup název podřízené složky. Díky předem 

HI seřazeno, upravil jsem kód odstraněný XFD a nastavil filpath jako xfditem