Macro to count the number of files in folder and subfolders

[LisaLou]

Hello,

I am really hoping someone can help me with this. I have VBA code to count the numbers of files in folders but I also need to count the number of files in sub folders too which the total will be displayed in cells in the excel spreadsheet. This is the code I have for counting in folders:

Private Sub countBatches()

Dim FolderPath As String, path As String, count As Integer, dayid As String

dayid = Range("B1").Value

FolderPath = "C:\Users\Lisap\OneDrive\Desktop\Orders\" & dayid & "\Batches"

path = FolderPath & "\*"

Filename = Dir(path)

Do While Filename <> ""
count = count + 1
Filename = Dir()
Loop

Range("B2").Value = count

End Sub


Please can anyone help with this? I would be most grateful!

 

[Fluff]

You cannot run the macro manually. If you add the message box as shown

   Dim Cl As Range
   MsgBox "Ok"
   If Target.CountLarge > 1 Then Exit Sub

and change the value in B1 does the message box appear?

 

[LisaLou]

I have added the above to the end of the Macro and this is all the code I have:

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim fso As Object, StartFldr As Object
   Dim StartPth As String, DayId As String
   Dim Cl As Range
   If Target.CountLarge > 1 Then Exit Sub
   If Target.Address(0, 0) = "B1" Then
      DayId = Range("B1").Value
      For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
         StartPth = "C:\Users\Lisap\OneDrive\Desktop\Orders\" & DayId & "\" & Cl.Value
         Set fso = CreateObject("Scripting.FileSystemObject")
         Set StartFldr = fso.GetFolder(StartPth)
         Call RecursiveFolder(fso, StartFldr, Cl.Row, True)
      Next Cl
   End If
End Sub

Sub RecursiveFolder(fso As Object, Fldr As Object, Rw As Long, IncludeSubFolders As Boolean)
   Dim FldrFile As Object
   Dim SubFldr As Object
   Dim NxtRw As Long

   Range("B" & Rw) = Range("B" & Rw) + Fldr.Files.Count

   If IncludeSubFolders Then
      For Each SubFldr In Fldr.SubFolders
         Call RecursiveFolder(fso, SubFldr, Rw, True)
      Next SubFldr
   End If
End Sub

Dim Cl As Range
   MsgBox "Ok"
   If Target.CountLarge > 1 Then Exit Sub

I have changed the value in B1 from Date to Date MMDDYY press enter and nothing happens.

 

[Fluff]

You need to add the message box to the existing code where I showed.

 

[LisaLou]

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim fso As Object, StartFldr As Object
   Dim StartPth As String, DayId As String
   Dim Cl As Range
   MsgBox "Ok"
   If Target.CountLarge > 1 Then Exit Sub
   If Target.Address(0, 0) = "B1" Then
      DayId = Range("B1").Value
      For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
         StartPth = "C:\Users\Lisap\OneDrive\Desktop\Orders\" & DayId & "\" & Cl.Value
         Set fso = CreateObject("Scripting.FileSystemObject")
         Set StartFldr = fso.GetFolder(StartPth)
         Call RecursiveFolder(fso, StartFldr, Cl.Row, True)
      Next Cl
   End If
End Sub

Sub RecursiveFolder(fso As Object, Fldr As Object, Rw As Long, IncludeSubFolders As Boolean)
   Dim FldrFile As Object
   Dim SubFldr As Object
   Dim NxtRw As Long

   Range("B" & Rw) = Range("B" & Rw) + Fldr.Files.Count

   If IncludeSubFolders Then
      For Each SubFldr In Fldr.SubFolders
         Call RecursiveFolder(fso, SubFldr, Rw, True)
      Next SubFldr
   End If
End Sub

I have added it where you said but still can't get it working. I don't know what I am doing wrong.

 

[Fluff]

Have you changed B1 after adding it?

 

[LisaLou]

Have you changed B1 after adding it?

Yes

 

[Fluff]

That sounds as though events have been disabled. Try closing Xl down completely, then open it up again & have another go.

 

[LisaLou]

That sounds as though events have been disabled. Try closing Xl down completely, then open it up again & have another go.

Still doesn't work. Thanks for all your help I really do appreciate it.

 

[Fluff]

Are you physically editing B1 & then pressing enter or tab?
Also do you still have that code in the relevant sheet module?

 

[LisaLou]

Are you physically editing B1 & then pressing enter or tab?
Also do you still have that code in the relevant sheet module?

I only have 1 module with this code:

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim fso As Object, StartFldr As Object
   Dim StartPth As String, DayId As String
   Dim Cl As Range
   MsgBox "Ok"
   If Target.CountLarge > 1 Then Exit Sub
   If Target.Address(0, 0) = "B1" Then
      DayId = Range("B1").Value
      For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
         StartPth = "C:\Users\Lisap\OneDrive\Desktop\Orders\" & DayId & "\" & Cl.Value
         Set fso = CreateObject("Scripting.FileSystemObject")
         Set StartFldr = fso.GetFolder(StartPth)
         Call RecursiveFolder(fso, StartFldr, Cl.Row, True)
      Next Cl
   End If
End Sub

Sub RecursiveFolder(fso As Object, Fldr As Object, Rw As Long, IncludeSubFolders As Boolean)
   Dim FldrFile As Object
   Dim SubFldr As Object
   Dim NxtRw As Long

   Range("B" & Rw) = Range("B" & Rw) + Fldr.Files.Count

   If IncludeSubFolders Then
      For Each SubFldr In Fldr.SubFolders
         Call RecursiveFolder(fso, SubFldr, Rw, True)
      Next SubFldr
   End If
End Sub

Yes, once I enter the date in B1 I am pressing enter.