6

我已经制作了一些子程序，它们在 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
4

1 回答 1

5

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
于 2013-03-14T20:48:06.260 回答