Can this be simplified?

[TheWennerWoman]

I have 40 queues to monitor with four sub-queues, so 160. I don't really want to write the below 160 times This is for the first queue (AQ1), the folder structure runs upto AQ40.

Sub CountFiles()

Dim strDir As String
Dim fso As Object
Dim objFiles As Object
Dim obj As Object
Dim lngFileCount As Long
       
strDir = "T:\X1Home\PDF_Poll\AQ1\Test\CREDIT\NONPOP\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFiles = fso.GetFolder(strDir).Files
lngFileCount = lngFileCount + objFiles.Count
ThisWorkbook.Worksheets("Sheet1").Range("B8").Value = objFiles.Count
ThisWorkbook.Worksheets("Sheet1").Range("A8").Value = strDir
ThisWorkbook.Worksheets("Sheet1").Range("C8").Value = Now()
    
strDir = "T:\X1Home\PDF_Poll\AQ1\Test\CREDIT\POP\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFiles = fso.GetFolder(strDir).Files
lngFileCount = lngFileCount + objFiles.Count
ThisWorkbook.Worksheets("Sheet1").Range("B9").Value = objFiles.Count
ThisWorkbook.Worksheets("Sheet1").Range("A9").Value = strDir
ThisWorkbook.Worksheets("Sheet1").Range("C9").Value = Now()

strDir = "T:\X1Home\PDF_Poll\AQ1\Test\INVOICE\NONPOP\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFiles = fso.GetFolder(strDir).Files
lngFileCount = lngFileCount + objFiles.Count
ThisWorkbook.Worksheets("Sheet1").Range("B10").Value = objFiles.Count
ThisWorkbook.Worksheets("Sheet1").Range("A10").Value = strDir
ThisWorkbook.Worksheets("Sheet1").Range("C10").Value = Now()
    
strDir = "T:\X1Home\PDF_Poll\AQ1\Test\INVOICE\POP\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFiles = fso.GetFolder(strDir).Files
lngFileCount = lngFileCount + objFiles.Count
ThisWorkbook.Worksheets("Sheet1").Range("B11").Value = objFiles.Count
ThisWorkbook.Worksheets("Sheet1").Range("A11").Value = strDir
ThisWorkbook.Worksheets("Sheet1").Range("C11").Value = Now()
End Sub

Thanks in advance as always

 

[RoryA]

You could do something like this:

Sub callit()
   Dim fso As Object
   Set fso = CreateObject("Scripting.FileSystemObject")
   
   Dim cell As Range
   Set cell = ThisWorkbook.Worksheets("Sheet1").Range("A8")
   
   Dim x As Long
   For x = 1 To 40
      QueueCount fso, "T:\X1Home\PDF_Poll\AQ" & x & "\Test\", cell
      ' move output cell down four rows
      Set cell = cell.Offset(4)
   Next x
End Sub
Sub QueueCount(fso As Object, FolderPath As String, outputCell As Range)
   Dim folderList
   folderList = Array("CREDIT\NONPOP\", "CREDIT\POP\", "INVOICE\NONPOP\", "INVOICE\POP\")
   Dim n As Long
   For n = LBound(folderList) To UBound(folderList)
      Dim strDir As String
      strDir = FolderPath & "\" & folderList(n)
      Dim objFiles As Object
      Set objFiles = fso.GetFolder(strDir).Files
      lngFileCount = lngFileCount + objFiles.Count
      outputCell.Offset(n).Resize(, 3).Value = Array(strDir, objFiles.Count, Now())
    Next n
End Sub

 

[TheWennerWoman]

That's genius thank you.

One further ask - it seems that a lot of these folders have a file called "thumbs.db" in? Can I exclude that particular file from the count?

 

[RoryA]

Try changing the second sub to this:

Sub QueueCount(fso As Object, FolderPath As String, outputCell As Range)
   Dim folderList
   folderList = Array("CREDIT\NONPOP\", "CREDIT\POP\", "INVOICE\NONPOP\", "INVOICE\POP\")
   Dim n As Long
   For n = LBound(folderList) To UBound(folderList)
      Dim strDir As String
      strDir = FolderPath & "\" & folderList(n)
      Dim objFiles As Object
      Set objFiles = fso.GetFolder(strDir).Files
      Dim thisFileCount As Long
      thisFileCount = objFiles.Count
      If Len(Dir(strDir & "thumbs.db")) <> 0 Then thisFileCount = thisFileCount - 1
      lngFileCount = lngFileCount + thisFileCount
      outputCell.Offset(n).Resize(, 3).Value = Array(strDir, thisFileCount, Now())
    Next n
End Sub

 

[TheWennerWoman]

Genius, works a treat. Thank you so much for your time.