VBA - Run code without crashing

DesAjax

New Member
Joined
Sep 19, 2014
Messages
2
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
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,163,714
Messages
5,833,279
Members
430,201
Latest member
Deepakpilla36

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top