Hello, I have a bunch of code as seen below that will count the number of files in a folder and subfolder based on the text found in A16. It will then paste the counters in a line on a main workbook. This works fine for smaller numbers of files but upon selecting a folder with a few hundred files, an error message will appear saying it is out of memory and the counters reset to 0. To stop it pasting 0, I have a line of code which prevents this, however, the code will simply stop running at this point.
Any help is much appreciated.
Any help is much appreciated.
Code:
Option ExplicitSub CountFiles()
Range("A1").Value = "Type"
Range("A2").Value = "All Time"
Range("B1").Value = "Duplicates"
Range("C1").Value = "Replicates"
Range("D1").Value = "Vinyl"
Range("A4").Value = "Errors"
Dim sFolder As String
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder..."
.Show
If .SelectedItems.count > 0 Then
sFolder = .SelectedItems(1) & "\"
End If
End With
Call Consolidate(sFolder, ThisWorkbook)
End Sub
Private Sub Consolidate(strFolder As String, wbMaster As Workbook)
Application.ScreenUpdating = True
Application.EnableEvents = False
Dim wbTarget As Workbook
Dim objFso As Object
Dim objFiles As Object
Dim objSubFolder As Object
Dim objSubFolders As Object
Dim objFile As Object
Dim sheet As Variant
Dim count As Integer
Dim count1 As Integer
Dim count2 As Integer
Dim countZ As Integer
Dim countE As Integer
On Error GoTo linemarkerError
'Create objects to enumerate files and folders
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFiles = objFso.getfolder(strFolder).Files
Set objSubFolders = objFso.getfolder(strFolder).Subfolders
'Loop through each file in the folder
For Each objFile In objFiles
On Error GoTo linemarkerError
If InStr(1, objFile.Path, ".xls") > 0 Then 'change the file type if needed but this will do all workbooks
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Set wbTarget = Workbooks.Open(objFile.Path)
Set sheet = wbTarget.Sheets
For Each sheet In wbTarget.Sheets
On Error GoTo linemarkersheet
linemarkerback: If sheet.Name = "JOB SHEET" Then 'change the sheetname as appropriate
countZ = 1
Exit For
End If
Next sheet
On Error GoTo linemarker2
With ThisWorkbook.Worksheets(1)
If countZ = 1 Then GoTo linemarker1 Else GoTo linemarker2
End With
linemarker1: countZ = 0 '======================================================
If wbTarget.Worksheets("JOB SHEET").Range("A16").Value = "NUMBER OF DISCS" Then GoTo LinemarkerA Else GoTo LinemarkerA2
LinemarkerA: count = count + 1
GoTo linemarker2 '====================================================
LinemarkerA2: If wbTarget.Worksheets("JOB SHEET").Range("A16").Value = "CD/DVD/PRINT ONLY" Then GoTo linemarkerC Else GoTo LinemarkerB2
linemarkerC: count1 = count1 + 1
GoTo linemarker2 '====================================================================
LinemarkerB2: If wbTarget.Worksheets("JOB SHEET").Range("A16").Value = "TP' S" Then GoTo linemarkerE Else GoTo LinemarkerC2 ' this is c2 not 2
linemarkerE: count2 = count2 + 1
LinemarkerC2:
linemarker2: countZ = 0
wbTarget.Close savechanges:=False
End If
If count + count1 + count2 <> 0 Then
With ThisWorkbook.Worksheets(1)
Range("B2").Value = count
Range("C2").Value = count1
Range("D2").Value = count2
Range("B4").Value = countE
End With
End If
'On Error Resume Next
linemarker3: Next objFile
'now for the subfolders subfolders
For Each objSubFolder In objSubFolders
Consolidate objSubFolder.Path, wbMaster
Next objSubFolder
'paste final results
If count + count1 + count2 <> 0 Then
With ThisWorkbook.Worksheets(1)
Range("B2").Value = count
Range("C2").Value = count1
Range("D2").Value = count2
Range("B4").Value = countE
End With
End If
'Clean up
Set objFile = Nothing
Set objFiles = Nothing
Set objFso = Nothing
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
Application.ScreenUpdating = True
Application.EnableEvents = True
GoTo linemarkerendsub
linemarkerError: countE = countE + 1
GoTo linemarker3
linemarkersheet: sheet.Unprotect Password:="Heslo"
GoTo linemarkerback
linemarkerendsub:
End Sub
Last edited:
