Working down a list

p0is0n0us

New Member
Joined
Apr 2, 2014
Messages
19
Hi,

I currently have a program where I can type a SSN in cell J1 and the program will go to a directory based on the SSN and do a page count of any PDF files that have the name APS in the title. I woud like to expand on this now and be able to put a list of SSN's in column J and have the program work its way down the list counting pages. I figure i need some kind of DO/LOOP command but I cant work it out. This is the code that I currently have:

Sub PageCount()
Dim MyPath As String, MyFile As String
Dim i As Long
MyPath = "I:\Images\" & Left(ActiveSheet.Range("J1").Value, 1) & "\" & ActiveSheet.Range("J1").Value
MyFile = Dir(MyPath & Application.PathSeparator & "*APS*.pdf", vbDirectory)
Range("A:B").ClearContents
Range("A1") = "File Name": Range("B1") = "Pages"
Range("A1:B1").Font.Bold = True
i = 1
Do While MyFile <> ""
i = i + 1
Cells(i, 1) = MyFile
Cells(i, 2) = GetPageNum(MyPath & Application.PathSeparator & MyFile)
MyFile = Dir
Loop
Columns("A:B").AutoFit
MsgBox "Total of " & i - 1 & " PDF files have been found" & vbCrLf _
& " File names and corresponding count of pages have been written on " _
& ActiveSheet.Name, vbInformation, "Report..."
End Sub
'
Function GetPageNum(PDF_File As String)
Dim FileNum As Long
Dim strRetVal As String
Dim RegExp
Set RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
RegExp.Pattern = "/Type\s*/Page[^s]"
FileNum = FreeFile
Open PDF_File For Binary As #FileNum
strRetVal = Space(LOF(FileNum))
Get #FileNum, , strRetVal
Close #FileNum
GetPageNum = RegExp.Execute(strRetVal).Count
End Function

Any help you could give me would be greatly appreciated.

Gaz
 

Excel Facts

Whats the difference between CONCAT and CONCATENATE?
The newer CONCAT function can reference a range of cells. =CONCATENATE(A1,A2,A3,A4,A5) becomes =CONCAT(A1:A5)
Try this modified version of your Sub procedure.
Code:
Sub PageCount2()
Dim MyPath As String, MyFile As String, c As Range
Dim i As Long
    For Each c In ActiveSheet.Range("J1", ActiveSheet.Cells(Rows.Count, "J").End(xlUp))
        MyPath = "I:\Images\" & Left(ActiveSheet.Range("J1").Value, 1) & "\" & c.Value
        MyFile = Dir(MyPath & Application.PathSeparator & "*APS*.pdf", vbDirectory)
        Range("A:B").ClearContents
        Range("A1") = "File Name": Range("B1") = "Pages"
        Range("A1:B1").Font.Bold = True
        i = 1
        Do While MyFile <> ""
            i = i + 1
            Cells(i, 1) = MyFile
            Cells(i, 2) = GetPageNum(MyPath & Application.PathSeparator & MyFile)
            MyFile = Dir
        Loop
    Next
Columns("A:B").AutoFit
MsgBox "Total of " & i - 1 & " PDF files have been found" & vbCrLf _
& " File names and corresponding count of pages have been written on " _
& ActiveSheet.Name, vbInformation, "Report..."
End Sub
You will still need the function to work in conjunction with the above procedure.
 
Upvote 0
Thank you for the quick reply JLGWhiz, its nearly there but it is not listing the files in columns A, B for new new SSN but instead over writing the old data.
 
Upvote 0
Thank you for the quick reply JLGWhiz, its nearly there but it is not listing the files in columns A, B for new new SSN but instead over writing the old data.

Had the For loop starting in the wrong place. See if this works.
Code:
Sub PageCount3()
Dim MyPath As String, MyFile As String, c As Range
Dim sh As Worksheet, i As Long
Set sh = ActiveSheet
sh.Range("A:B").ClearContents
sh.Range("A1") = "File Name"
sh.Range("B1") = "Pages"
Range("A1:B1").Font.Bold = True 
    For Each c In sh.Range("J1", ActiveSheet.Cells(Rows.Count, "J").End(xlUp))
        MyPath = "I:\Images\" & Left(sh.Range("J1").Value, 1) & "\" & c.Value
        MyFile = Dir(MyPath & Application.PathSeparator & "*APS*.pdf", vbDirectory)        
        i = 1
        Do While MyFile <> ""
            i = i + 1
            Cells(i, 1) = MyFile
            Cells(i, 2) = GetPageNum(MyPath & Application.PathSeparator & MyFile)
            MyFile = Dir
        Loop
    Next
Columns("A:B").AutoFit
MsgBox "Total of " & i - 1 & " PDF files have been found" & vbCrLf _
& " File names and corresponding count of pages have been written on " _
& ActiveSheet.Name, vbInformation, "Report..."
End Sub
 
Upvote 0
I moved the I=1 to just under set sh = activesheet and that seem ed to work. For some raeson though if I copy a list of SSN's into column J it will not process all of them?
 
Upvote 0
Sorry JLGWhiz it's still overwriting column A and B, thank you for helping.

A little more tweaking.
Code:
Sub PageCount4()
Dim MyPath As String, MyFile As String, c As Range
Dim sh As Worksheet, i As Long
Set sh = ActiveSheet
sh.Range("A:B").ClearContents
sh.Range("A1") = "File Name"
sh.Range("B1") = "Pages"
sh.Range("A1:B1").Font.Bold = True 
    For Each c In sh.Range("J1", ActiveSheet.Cells(Rows.Count, "J").End(xlUp))
        MyPath = "I:\Images\" & Left(sh.Range("J1").Value, 1) & "\" & c.Value
        MyFile = Dir(MyPath & Application.PathSeparator & "*APS*.pdf", vbDirectory)        
        Do While MyFile <> ""            
            sh.Cells(Rows.Count, 1).End(xlUp)(2) = MyFile
            sh.Cells(Rows.Count, 2).End(xlUp)(2) = GetPageNum(MyPath & Application.PathSeparator & MyFile)
            MyFile = Dir
        Loop
    Next
sh.Columns("A:B").AutoFit
MsgBox "Total of " & i - 1 & " PDF files have been found" & vbCrLf _
& " File names and corresponding count of pages have been written on " _
& ActiveSheet.Name, vbInformation, "Report..."
End Sub
 
Upvote 0
Hi JLGWhiz, that part now works thank you for your help. I found that there is an issue when changing the first number of the SSN. For instance if the SSN is 223451212 then the folder will map to I:\Images\2\223451212. An issue is occuring when the first character then changes so 321437667 would be I:\Images\3\321437667. The code is stopping when the folder number changes. I think that this has something to do with the line MyPath = "I:\Images\" & Left(sh.Range("J1").Value, 1) & "\" & c.Value..

Thank you for your assistants with this, its much appreciated.
 
Upvote 0
Maybe change this line:
Code:
MyPath = "I:\Images\" & Left(sh.Range("J1").Value, 1) & "\" & c.Value
To this
Code:
MyPath = "I:\Images\" & Left(c.Value, 1) & "\" & c.Value
I missed that before.
Also your message box will need some adjustment. You can add this line after 'MyFile = Dir'.
Code:
i = i + 1
That should them give you the count of processed ssn.
Regards, JLG
 
Upvote 0

Forum statistics

Threads
1,213,482
Messages
6,113,913
Members
448,532
Latest member
9Kimo3

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top