I made several routines, and they did a great job in the test phase on 5 files, but when I put them on real data, i.e. 600 files, after a while I will get this message:
Excel cannot complete this task with available resources. Select less data or close other applications.
I searched for it and most of them was application.cutcopymode = false , but in my code I do not use cut and copy mode, but I process copy using
destrange.Value = sourceRange.Value
And when I turn to debugging, I mean that after requesting an error, it takes me to the same line of code. If someone is faced with a similar situation and knows how to solve the problem, I would be grateful.
Just to make sure, I tried application.cutcopymode = false and that didn't help. I open each of these 600 files, sort by different criteria and from each copy first 100 into a new book (one after another), and when I finish with one criterion, I save and close this new book and open a new one and continue to extract data for different criteria.
If someone is interested in helping, I can also provide code, but in order to make the question simple, I did not. Any help or suggestion is more than welcome. Thanks.
EDIT:
Here is the main part: (The goal is to take information from the book about how many first lines I need to copy, because I need to copy the first 100 once, then 50, then 20, then 10 ...)
Sub final() Dim i As Integer Dim x As Integer For i = 7 To 11 x = ThisWorkbook.Worksheets(1).Range("N" & i).Value Maximum_sub x Minimum_sub x Above_Average_sub x Below_Average_sub x Next i End Sub
And here is one of these submarkes: (Others are basically the same, just change the sorting criteria.)
Sub Maximum_sub(n As Integer) Dim MyPath As String, FilesInPath As String Dim MyFiles() As String Dim SourceRcount As Long, FNum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long Dim srt As Sort ' The path\folder location of your files. MyPath = "C:\Excel\" ' If there are no adequate files in the folder, exit. FilesInPath = Dir(MyPath & "*.txt") If FilesInPath = "" Then MsgBox "No files found" Exit Sub End If ' Fill the myFiles array with the list of adequate files ' in the search folder. FNum = 0 Do While FilesInPath <> "" FNum = FNum + 1 ReDim Preserve MyFiles(1 To FNum) MyFiles(FNum) = FilesInPath FilesInPath = Dir() Loop 'get a number: take a top __ from each 'n = ActiveWorkbook.Worksheets(1).Range("B4").Value ' Add a new workbook with one sheet. Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) rnum = 1 ' Loop through all files in the myFiles array. If FNum > 0 Then For FNum = LBound(MyFiles) To UBound(MyFiles) Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) ' Change this to fit your own needs. ' Sorting Set srt = mybook.Worksheets(1).Sort With srt .SortFields.Clear .SortFields.Add Key:=Columns("C"), SortOn:=xlSortOnValues, Order:=xlDescending .SetRange Range("A1:C18000") .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With 'Deleting nulls Do While (mybook.Worksheets(1).Range("C2").Value = "null") mybook.Worksheets(1).Rows(2).Delete Loop Set sourceRange = mybook.Worksheets(1).Rows("2:" & n + 1) SourceRcount = sourceRange.Rows.Count Set destrange = BaseWks.Range("A" & rnum) BaseWks.Cells(rnum, "A").Font.Bold = True BaseWks.Cells(rnum, "B").Font.Bold = True BaseWks.Cells(rnum, "C").Font.Bold = True Set destrange = destrange.Resize(sourceRange.Rows.Count, sourceRange.Columns.Count) destrange.Value = sourceRange.Value rnum = rnum + SourceRcount mybook.Close savechanges:=False Next FNum BaseWks.Columns.AutoFit End If BaseWks.SaveAs Filename:="maximum_" & CStr(n) Activewoorkbook.Close End Sub