Отсутствие памяти Excel VBA

Я сделал несколько подпрограмм, и они отлично работали на тестовой фазе на 5 файлов, но когда я положил их на реальные данные, то есть 600 файлов, через некоторое время я получу это сообщение:

Excel не может выполнить эту задачу с доступными ресурсами. Выбирайте меньше данных или закрывайте другие приложения.

Я искал его, и большинство из них было найдено application.cutcopymode = false , но в моем коде я не использую режим вырезания и копирования, но обрабатываю копирование с помощью

• Электронная таблица :: WriteExcel set_optimization () генерирует ошибки разблокировки
• Получение OOM с обработкой .xls с использованием PHPExcel
• Сколько памяти может иметь плагин Excel XLL?
• VBA Excel больших манипуляций с данными навсегда
• Случайные символы от литья строки Arduino в Excel BSTR через c ++ DLL

 destrange.Value = sourceRange.Value 

И когда я перехожу к отладке, я имею в виду, что после запроса ошибки он принимает меня к этой же строке кода. Если кто-то столкнулся с подобной ситуацией и знает, как решить проблему, я был бы благодарен.

Просто, чтобы проясниться, я пробовал application.cutcopymode = false и это не помогло. Я открываю каждый из этих 600 файлов, сортируюсь по разным критериям и из каждой копии сначала 100 в новую книгу (один за другим), и когда я заканчиваю одним критерием, я сохраняю и закрываю эту новую книгу и открываю новую и продолжаю извлекать данные по разные критерии.

Если кто-то заинтересован помочь, я также могу предоставить код, но для того, чтобы сделать вопрос простым, я этого не сделал. Любая помощь или предложение более чем приветствуются. Спасибо.

РЕДАКТИРОВАТЬ:

Вот основная часть: (Цель состоит в том, чтобы взять из рабочей книги информацию о том, сколько первых строк нужно копировать, потому что мне нужно один раз скопировать первые 100, затем 50, затем 20, затем 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 

И вот одно из этих подсайтов: (Другие в основном одинаковы, просто изменяют критерии сортировки).

 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 

 sub try() dim last_col_ad as string dim last_col as string last_col_ad = mybook.Worksheets(1).Range("XFD1").End(xlLeft).Address last_col = Replace(Cells(1, LastColumn).Address(False, False), "1", "") Set SourceRange = mybook.Worksheets(1).Range("A2:" & last_col & n + 1) end sub