内存缺少Excel VBA

Question

我已经做了一些子程序,他们在5个文件的测试阶段工作得很好,但是当我把它们用于处理真实数据时,就是600个文件,经过一段时间后我得到了这个消息:

Excel无法使用可用资源完成此任务.选择较少的数据或关闭其他应用程序.

我用谷歌搜索了它,我找到的最多application.cutcopymode = false,但是在我的代码中,我没有使用剪切和复制模式,而是处理复制

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

Answer 1

Set sourceRange = mybook.Worksheets(1).Rows("2:" & n + 1) 将在最后一列之后选择所有空列并炸掉你的记忆

使这个更动态的插入(未测试)

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