Working down a list

[p0is0n0us]

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

 

[JLGWhiz]

Try this modified version of your Sub procedure.

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.

 

[p0is0n0us]

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.

 

[JLGWhiz]

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.

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

 

[p0is0n0us]

Sorry JLGWhiz it's still overwriting column A and B, thank you for helping.

 

[p0is0n0us]

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?

 

[JLGWhiz]

Sorry JLGWhiz it's still overwriting column A and B, thank you for helping.

A little more tweaking.

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

 

[p0is0n0us]

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.

 

[JLGWhiz]

Maybe change this line:

MyPath = "I:\Images\" & Left(sh.Range("J1").Value, 1) & "\" & c.Value

To this

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'.

i = i + 1

That should them give you the count of processed ssn.
Regards, JLG

 

[p0is0n0us]

The program now works thank you so much. You've saved me a lot of time, much appreciated