Bellek eksikliği Excel VBA

Question

Bazı altyordamlarını yaptık ve onlar 5 dosyalar üzerinde test aşamasında harika çalıştı, ancak ben gerçek veriler üzerinde çalışmak için onları koyduğunuzda, o bir süre sonra bu mesaj çıktı, 600 dosyalar:

Excel, bu görevi kullanılabilir kaynaklarla tamamlayamıyor. Daha az veri seç veya diğer uygulamaları kapat.

Ben googled ettik ve ben bulunan en application.cutcopymode = false, ama ayıklama giderken benim kodda kesme kullanarak ve kopya modu, ancak

destrange.Value = sourceRange.Value 

ile kopyalama işlemek Ve değilim Yani, hata istemi sonrası beni aynı kod satırına götürür. Eğer benzer bir durumla karşılaştıysa ve sorunu nasıl çözeceğini biliyorsa minnettar olurum.

Sadece kendimi netleştirmek için application.cutcopymode = false'u denedim ve yardımcı olmadı. Bu 600 dosyanın her birini açıyor, farklı ölçütlere göre sıralıyorum ve her kopyadan 100 önce yeni çalışma kitabına (birbiri ardına) ve bir ölçütle bitirdiğimde, yeni çalışma kitabını kaydedip kapatıp yeni açıp veri ayıklamaya devam ediyorum. farklı kriterler.

Birisi yardım etmekle ilgileniyorsa, aynı zamanda kod da sağlayabilirim, ancak soruları basitleştirmek için yapmadım. Herhangi bir yardım veya öneri memnuniyetle karşılanıyor. Teşekkür ederim.

DÜZENLEME: İşte

ana alt bağlıdır: (Ben ilk 100 kopya için bir kez ihtiyaç yüzünden olduğunu amacı sonra, o zaman, o zaman, ilk sıraları kopyalamak için kaç üzerindeki çalışma kitabı bilgilerinden almaya 20 50 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 

Ve bu denizaltılar biridir: (Diğerleri temelde aynı, sadece sıralama kriterleri değişikliklerdir)

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) son sütunda sonra tüm boş sütunları seçin ve bu daha dinamik insert ( test edilmedi)

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