Brak pamięci Excel VBA

Question

Zrobiłem kilka podprogramów i działały one świetnie w fazie testowej na 5 plikach, ale kiedy umieściłem je do pracy na prawdziwych danych, to jest 600 plików, po pewnym czasie dostaję ten komunikat:

Program Excel nie może wykonać tego zadania z dostępnymi zasobami. Wybierz mniej danych lub zamknij inne aplikacje.

Mam googled go i najbardziej znalazłem application.cutcopymode = false, ale w moim kodu nie używam cięcie i trybu kopiowania, ale obsługiwać kopiowanie z

destrange.Value = sourceRange.Value 

I kiedy idę do debugowania Mam na myśli, po błędzie błędu, że zabiera mnie do tego samego wiersza kodu. Jeśli ktokolwiek napotkał podobną sytuację i wie, jak rozwiązać problem, byłbym wdzięczny.

Tylko po to, aby się upewnić, że wypróbowałem application.cutcopymode = false i to nie pomogło. Otwieram każdy z tych 600 plików, sortuję według różnych kryteriów i od każdej kopii najpierw 100 do nowego skoroszytu (jeden po drugim) i kiedy kończę z jednym kryterium zapisuję i zamykam ten nowy skoroszyt i otwieram nowe i kontynuuję wyodrębnianie danych przez różne kryteria.

Jeśli ktoś jest zainteresowany pomocą, mogę również podać kod, ale dla uproszczenia pytania nie. Każda pomoc lub sugestia jest więcej niż mile widziane. Dziękuję Ci.

EDIT:

Oto główny sub (Jego celem jest podjęcie na podstawie informacji skoroszytu na ile pierwsze rzędy na kopiowanie, ponieważ muszę raz skopiować pierwszych 100, potem 50, potem 20, potem 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 

A oto jeden z tych subwooferów: (Inne są zasadniczo takie same, tylko kryteria sortowania zmiany)

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 

Answer 1

. Set sourceRange = mybook.Worksheets(1).Rows("2:" & n + 1) wybierze wszystkie puste kolumny po ostatniej kolumnie i wysadzić swoją pamięć

Aby to bardziej dynamiczny wkładkę (nie testowano)

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