vba - Excel VBA 内存不足

Question

我制作了一些子例程，它们在 5 个文件的测试阶段工作得很好，但是当我将它们用于实际数据(即 600 个文件)时，一段时间后我收到此消息:

Excel cannot complete this task with available resources. Chose less data or close other applications.

我用谷歌搜索了它，我发现最多的是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