Hej Fawaz,
Koden fungerar bra i min Excel, vilken Excel-version använder du?
Eller så kan du skicka ditt detaljerade problem eller pdf-filer till min e-post: skyyang@extendoffice. Com.

Hej, Venkatesh G
Koden fungerar bra i min Excel, skicka dina pdf-filer till min e-post: yy@addin99.com.
Så att vi kan kolla var problemet ligger, tack!

Hej Prashant,
För att få numret på alla PDF-filer från mappar och undermappar, använd koden nedan:

Delprov ()
Dim I As Long
Dim xRg As Range
Dim xStr As String
Dim xFd As FileDialog
Dim xFdItem som variant
Dim xFileName As String
Dim xFileNum As Long
Dim RegExp som objekt
Ställ in xFd = Application.FileDialog(msoFileDialogFolderPicker)
Om xFd.Show = -1 Då
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
Ställ in xRg = Range("A1")
Range("A:B"). ClearContents
Range("A1:B1"). Font.Bold = True
xRg = "Filnamn"
xRg.Offset(0, 1) = "Sidor"
I = 2
Ring 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 som objekt
Dim xF som objekt
Dim xSF som objekt
Dim xFso som objekt
xFilnamn = Dir(xFdItem & "*.pdf", vbDirectory)
xStr = ""
Gör medan xFileName <> ""
Cells(I, 1) = xFilnamn
Ange RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = Sant
RegExp.Pattern = "/Typ\s*/Page[^s]"
xFileNum = FreeFile
Öppna (xFdItem & xFileName) för binärt som #xFileNum
xStr = Mellanslag(LOF(xFileNum))
Skaffa #xFileNum, , xStr
Stäng #xFileNum
Cells(I, 2) = RegExp.Execute(xStr).Count
I = I + 1
xFilnamn = Dir
loop
Kolumner("A:B"). Autoanpassa
Ställ in xFso = CreateObject("Scripting.FileSystemObject")
Ställ in xF = xFso.GetFolder(xFdItem)
För varje xSF i xF.SubFolders
Ring SunTest(xSF.Path & "\", I)
Nästa
End Sub

Försök gärna, hoppas det kan hjälpa dig!

Kan du hjälpa mig att också få fram skaparen och måtten på filen?

Hallå,
Varsågod. Kul att det hjälper. Har du frågor, kontakta oss gärna. Ha en bra dag.
Vänliga hälsningar,
Mandy

Tack så mycket.
På samma sätt, kan du räkna och kategorisera A3- och A4-sidor?

Här är koden jag hittade någonstans på nätet, den är inte lika optimal som din metod:
Explicit alternativ
Public PDFDoc As AcroPDDoc, PDFPage As Object, A3&, A4&

Sub Main ()
Dim fso As FileSystemObject, fld As Folder, fil As File, s$, i&, Arr()
Ställ in fso = New FileSystemObject
Ställ in PDFDoc = New AcroPDDoc
Ange fld = fso.GetFolder(ThisWorkbook.Path)
ReDim Arr(1 till 1000, 1 till 3)
För varje fil I fld.Files
s = fil.namn
Om Right(s, 4) = ".pdf" Då
CountPagesPDF (This Workbook.Path & "\" & s)
i = i + 1
Arr(i, 1) = s
Arr(i, 2) = A3
Arr(i, 3) = A4
End If
Nästa
Range("A2:C" & Cells.Rows.Count). Rensa
Område("A2:C" & (i + 1)) = Arr
Ställ in PDFPage = Ingenting
Ställ in PDFDoc = Ingenting
Ställ in fso = Ingenting
End Sub

Sub CountPagesPDF(FullFileName$)
Dim i&, n&, x, y
A3 = 0
A4 = 0
PDFDoc.Open (FullFileName)
n = PDFDoc.GetNumPages
För i = 0 Till n - 1
Ställ in PDFPage = PDFDoc.AcquirePage(i)
x = PDFPage.GetSize().x
y = PDFPage.GetSize().y
Om x + y > 1500 då A3 = A3 + 1 Annars A4 = A4 + 1
Nästa
PDFDoc.Close
End Sub

Hej Daphne,
För att lösa ditt problem, använd koden nedan, försök, hoppas det kan hjälpa dig!

Delprov ()
Dim I As Long
Dim xRg As Range
Dim xStr As String
Dim xFd As FileDialog
Dim xFdItem som variant
Dim xFileName As String
Dim xFileNum As Long
Dim RegExp som objekt
Ställ in xFd = Application.FileDialog(msoFileDialogFolderPicker)
Om xFd.Show = -1 Då
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
Ställ in xRg = Range("A1")
Range("A:B"). ClearContents
Range("A1:B1"). Font.Bold = True
xRg = "Filnamn"
xRg.Offset(0, 1) = "Sidor"
xRg.Offset(0, 2) = "Sökväg"
xRg.Offset(0, 3) = "Storlek(b)"
I = 2
Ring 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 som objekt
Dim xF som objekt
Dim xSF som objekt
Dim xFso som objekt
xFilnamn = Dir(xFdItem & "*.pdf", vbDirectory)
xStr = ""
Gör medan xFileName <> ""
Cells(I, 1) = xFilnamn
Ange RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = Sant
RegExp.Pattern = "/Typ\s*/Page[^s]"
xFileNum = FreeFile
Öppna (xFdItem & xFileName) för binärt som #xFileNum
xStr = Mellanslag(LOF(xFileNum))
Skaffa #xFileNum, , xStr
Stäng #xFileNum
Cells(I, 2) = RegExp.Execute(xStr).Count
Cells(I, 3) = xFdItem & xFileName
Cells(I, 4) = FileLen(xFdItem & xFileName)
I = I + 1
xFilnamn = Dir
loop
Kolumner("A:B"). Autoanpassa
Ställ in xFso = CreateObject("Scripting.FileSystemObject")
Ställ in xF = xFso.GetFolder(xFdItem)
För varje xSF i xF.SubFolders
Ring SunTest(xSF.Path & "\", I)
Nästa
End Sub

Hej skyyang,
Förlåt att jag stöter på ett gammalt inlägg.
Tack för koden ovan, den hjälper mig så mycket!
Skulle du vara snäll nog att dela med dig av hur man lägger till "filens skapandedatum" även där formatet endast är datumet, ingen tid inkluderad, DD/MMM/ÅÅÅÅ?
Oavsett var jag söker så verkar jag inte kunna redigera din kod för att göra detta korrekt själv..

Tack på förhand!

Stråle

Hej Flavio,
För att få numret på alla PDF-filer från mappar och undermappar, använd koden nedan:

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

Försök gärna, hoppas det kan hjälpa dig!

Hej Flavio,
Du kan ladda upp din PDF-fil här, så att vi kan kontrollera problemet.
Tack!

Hej, SrdosPDF
Följande VBA-kod kan göra dig en tjänst, prova den:

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

Hoppas detta kan hjälpa dig!

Hej sroczeto,
För att räkna sidnumret för .doc och .docx samt PDF-filerna, använd följande kod:
Delprov ()
Dim I As Long
Dim xRg As Range
Dim xStr As String
Dim xFd As FileDialog
Dim xFdItem som variant
Dim xFileName As String
Dim xFileNum As Long
Dim RegExp som objekt
Dim xWdApp
Dim xWd
Ställ in xFd = Application.FileDialog(msoFileDialogFolderPicker)
Om xFd.Show = -1 Då
Application.ScreenUpdating = False
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFilnamn = Dir(xFdItem & "*.pdf", vbDirectory)
Ställ in xRg = Range("A1")
Range("A:B"). ClearContents
Range("A1:B1"). Font.Bold = True
xRg = "Filnamn"
xRg.Offset(0, 1) = "Sidor"
I = 2
xStr = ""
Gör medan xFileName <> ""
Cells(I, 1) = xFilnamn
Ange RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = Sant
RegExp.Pattern = "/Typ\s*/Page[^s]"
xFileNum = FreeFile
Öppna (xFdItem & xFileName) för binärt som #xFileNum
xStr = Mellanslag(LOF(xFileNum))
Skaffa #xFileNum, , xStr
Stäng #xFileNum
Cells(I, 2) = RegExp.Execute(xStr).Count
I = I + 1
xFilnamn = Dir
loop
xFilnamn = Dir(xFdItem & "*.docx", vbDirectory)
Ställ in xWdApp = CreateObject("Word.Application")
Gör medan xFileName <> ""
Cells(I, 1) = xFilnamn
xFileNum = FreeFile
Ställ in xWd = GetObject(xFdItem & xFileName)
Celler(I, 2) = xWd.ActiveWindow.Panes(1).Pages.Count
xWd.Stäng Falskt
I = I + 1
xFilnamn = Dir
loop
Kolumner("A:B"). Autoanpassa
End If
Application.ScreenUpdating = True
End Sub

Tack mate! Det fungerar på pdf och docx, men inte på doc-filer. Och en fråga till, kan du tillägga att detta kommer att räknas i undermappar också?

Hej John! För att räkna sidorna i .doc och .docx samt PDF-filerna, använd följande kod: Understatistiksida()
Dim I As Long
Dim xRg As Range
Dim xStr As String
Dim xFd As FileDialog
Dim xFdItem som variant
Dim xFileName As String
Dim xFileNum As Long
Dim RegExp som objekt
Dim xWdApp
Dim xWd
Ställ in xFd = Application.FileDialog(msoFileDialogFolderPicker)
Om xFd.Show = -1 Då
Application.ScreenUpdating = False
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFilnamn = Dir(xFdItem & "*.pdf", vbDirectory)
Ställ in xRg = Range("A1")
Range("A:B"). ClearContents
Range("A1:B1"). Font.Bold = True
xRg = "Filnamn"
xRg.Offset(0, 1) = "Sidor"
I = 2
xStr = ""
Gör medan xFileName <> ""
Cells(I, 1) = xFilnamn
Ange RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = Sant
RegExp.Pattern = "/Typ\s*/Page[^s]"
xFileNum = FreeFile
Öppna (xFdItem & xFileName) för binärt som #xFileNum
xStr = Mellanslag(LOF(xFileNum))
Skaffa #xFileNum, , xStr
Stäng #xFileNum
Cells(I, 2) = RegExp.Execute(xStr).Count
I = I + 1
xFilnamn = Dir
loop
xFilnamn = Dir(xFdItem & "*.docx", vbDirectory)
Ställ in xWdApp = CreateObject("Word.Application")
Gör medan xFileName <> ""
Cells(I, 1) = xFilnamn
xFileNum = FreeFile
Ställ in xWd = GetObject(xFdItem & xFileName)
Celler(I, 2) = xWd.ActiveWindow.Panes(1).Pages.Count
xWd.Stäng Falskt
I = I + 1
xFilnamn = Dir
loop
xFilnamn = Dir(xFdItem & "*.doc", vbDirectory)
Ställ in xWdApp = CreateObject("Word.Application")
Gör medan xFileName <> ""
Cells(I, 1) = xFilnamn
xFileNum = FreeFile
Ställ in xWd = GetObject(xFdItem & xFileName)
Celler(I, 2) = xWd.ActiveWindow.Panes(1).Pages.Count
xWd.Stäng Falskt
I = I + 1
xFilnamn = Dir
loop
Kolumner("A:B"). Autoanpassa
End If
Application.ScreenUpdating = True
Avsluta SubSnälla försök, hoppas det kan hjälpa dig!

Hej, jag har en mapp med flera undermappar. Hur kan jag ange den överordnade mappen Sökväg utan att manuellt välja den. Sedan också utgången namnet på den underordnade mappen. Tack på förhand 

HI sorterade jag har redigerat koden bort XFD och satt filpath som xfditem