Memory lack Excel VBA
excel, memory, vba
Solution
`Set sourceRange = mybook.Worksheets(1).Rows("2:" & n + 1)` will select all the empty columns after your last column and blow up your memory
To make this more dynamic insert (not tested)
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
Problem
I have made some subroutines and they worked great in test phase on 5 files, but when I put them to work on real data, that is 600 files, after some time I get this message: Excel cannot complete this task with available resources. Chose less data or close other applications. I've googled it and the most I found was `application.cutcopymode = false`, but in my code I'm not using cut and copy mode, but handle copying with ``` destrange.Value = sourceRange.Value ``` And when I go to debug, I mean after error prompt it takes me to this same line of code. If anyone has encountered similar situation, and knows how to solve the problem I would be grateful. Just to make myself clear I have tried `application.cutcopymode = false` and it didn't help. I'm opening each of this 600 files, sort by different criteria and from each copy first 100 into new workbook (one after another) and when I finish with one criteria I save and close that new workbook and open new and continue extracting data by different criteria. If someone is interested to help I also can provide code, but for making question simple I didn't. Any help or suggestion is more than welcome. Thank you. EDIT: Here is main sub: (It's purpose is to take from workbook information on how many first rows to copy, because I need once to copy first 100, 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 this subs: (Others are basically the same, just sort criteria changes.) ``` 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 ```