VBA - Run code without crashing

[DesAjax]

Hello,

I have made the vba-code below myself (I'm a beginner with vba). The code performs well with smaller amounts of files, but it seems that the code has problems processing large amounts of files. What can be changed about the code to process a lot of files, without the workbook crashing?

I want to achieve the following. The code has to search in all the 3th subfolders of the main folder ("C:\Users\NameUser\Documents\Test"). The code has to open every Excel workbook in the 3th subfolders, one at a time, unlock it with a password and copy some values from two specific cells. The values will than be pasted in the workbook that runs the code. It will also paste the name of the file in the workbook that runs the code. The openened workbook will than be protected agai with a password and will be closed. The values of the next workbook wil be pasted one step below the values from the first workbook. And so on.

The reason that I can't name the direct path to the right folders, is because the names of the subfolders of the main folder all have different names.



Sub CopyData()
Dim SearchFileName As String
Dim SearchSheet As String
Dim SearchCell As String
Dim SearchSheet2 As String
Dim SearchCell2 As String
Dim Password As String
Dim FileName As String
Dim Extension As String
Dim SourceFolder As Object
Dim SourceSubFolder As Object
Dim SubFolder As Object
Dim SubSubFolder As Object
Dim SubSubSubFolder As Object
SearchFileName = Application.InputBox(Prompt:="Search for which file name?")
SearchSheet = Application.InputBox(Prompt:="Search in which sheet? (criteria 1)")
SearchCell = Application.InputBox(Prompt:="Search in which cell? (criteria 1)")
SearchSheet2 = Application.InputBox(Prompt:="Search in which sheet? (criteria 2)")
SearchCell2 = Application.InputBox(Prompt:="Search in which cell? (criteria 2)")
Password = Application.InputBox(Prompt:="Password Excel-file")
On Error Resume Next
Set SourceFolder = CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\NameUser\Documents\Test")
i = 1
For Each SubFolder In SourceFolder.SubFolders
On Error Resume Next
Set SourceSubFolder = CreateObject("Scripting.FileSystemObject").GetFolder(SubFolder.Path)
For Each SubSubFolder In SourceSubFolder.SubFolders
On Error Resume Next
Set SourceSubSubFolder = CreateObject("Scripting.FileSystemObject").GetFolder(SubSubFolder.Path)
For Each SubSubSubFolder In SourceSubSubFolder.SubFolders
On Error Resume Next
Set SourceSubSubSubFolder = CreateObject("Scripting.FileSystemObject").GetFolder(SubSubSubFolder.Path)
For Each file In SourceSubSubSubFolder.Files
On Error Resume Next
FileName = Dir$(file.Path)
Extension = "xls"
If InStr(file.Name, SearchFileName) And InStr(FileName, Extension) Then
Workbooks.Open (file.Path)
ThisWorkbook.Worksheets(1).Cells(i, 1) = file.Path
ActiveWorkbook.Unprotect (Password)
ActiveWorkbook.Worksheets(SearchSheet).Range(SearchCell & ":" & SearchCell & SearchRow).Copy
ThisWorkbook.Worksheets(1).Cells(i, 2).PasteSpecial xlPasteValues
ActiveWorkbook.Worksheets(SearchSheet2).Range(SearchCell2 & ":" & SearchCell2).Copy
ThisWorkbook.Worksheets(1).Cells(i, 3).PasteSpecial xlPasteValues
ActiveWorkbook.Protect (Password)
ActiveWorkbook.Close (SaveChanges = False)
i = i + 1
End If
Next file
Next SubSubSubFolder
Next SubSubFolder
Next SubFolder
ThisWorkbook.Worksheets(1).Columns.AutoFit
End Sub