CODEWITHSUNDEEP
excelvba
user3390169
user3390169

Reputation: 1045

Macro unable to finish, is my sheet too big?

I have been trying to run what I thought was a simple macro for two days and keep running into this error:

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

I would love to get 20,000 iterations out of the macro but the error shows up way sooner than that. I think it stops around 5,000. Even worse is that I can't save what I do get afterward. I know there is a somewhat large amount of data after that many iterations but nowhere near filling an entire sheet. I would like to be able to run the macro and then optimize the weights out to the right.

Code:

Sub Macro1()

    Application.ScreenUpdating = False

    For i = 1 To 20000

        Rows("16:28").Select
        Selection.Copy
        Range("D1048576").End(xlUp).Offset(2, -3).Select
        ActiveSheet.Paste

        Selection.Resize(13, 288).Select
        Selection.Copy

        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False

        If i Mod 1000 = 0 Then
            ActiveWorkbook.Save
        End If

    Next i

    Application.ScreenUpdating = True

End Sub

Sample data:

enter image description here

Sorry, I forgot to post a link to the workbook:

https://drive.google.com/open?id=0B0F1yWDNKi2vLWhmUDMtU2xsd00

Upvotes: 0

Views: 807

Answers (2)

paul bica
paul bica

Reputation: 10715

Your code copies all data from row 16 to 28, for 20,000 times, with and empty row between sets.

This code performs the same operation (in about 1 minute):

Option Explicit

Sub copyData()
    Const F_ROW     As Long = 16
    Const F_COL     As Long = 3
    Const SEP       As Long = 2
    Const COPIES    As Long = 20000

    Dim ws As Worksheet, i As Long, t As Double, allR As Long
    Dim srcRng As Variant, lr As Long, lc As Long

    Set ws = Worksheets("Sheet1")
    With ws
        lr = .Cells(.Rows.Count, F_COL + 1).End(xlUp).Row           'last row of data
        lc = .Cells(F_ROW + 1, .Columns.Count).End(xlToLeft).Column 'last col of data

        allR = lr - F_ROW
        srcRng = .Range(.Cells(F_ROW, F_COL), .Cells(lr, lc)).Formula

        Application.Calculation = xlCalculationManual
        For i = 1 To COPIES
            .Range(.Cells(lr + SEP, F_COL), .Cells(lr + allR + SEP, lc)).Formula = srcRng
            lr = lr + allR + SEP
        Next
        Application.Calculation = xlCalculationAutomatic

        .Calculate
        .Cells(1, 1).Activate
    End With
End Sub

.

Notes:

  • It generates 280,028 rows with 423 columns so you should save it as .xlsb:

    • .xlsm: file size 772 Mb - 5 min to save, 3 min to open

    • .xlsb: file size 475 Mb - 1 min to save, 1 min to open

.

Edit:

I changed the code to copy .Formula instead of .Value2 and ran into the same issue:

  • Excel runs out of memory when i = 1,276 (completed rows: 17,882)
  • 13 rows X 421 columns = 5,473 cells, with a total of 4,979 formulas
  • Task Mgr: Excel.exe - Memory (Private Working Set): 1,833,524 Kb (out of memory)

  • Application.Calculation = xlCalculationManual doesn't solve the problem

  • I also tried to run the code for 1,000 iterations, then manually copy and paste 20 more times

    • It ran out of memory ("Excel cannot complete this task with available resources...")

  • Last attempt was in Notepad++ to exclude calculations from the process

    • In Excel: Formulas -> Show Formulas (in Formula Auditing section), then copy
    • In Notepad: paste formulas
    • Copy lines 16 to 28 + a blank row
    • Pasted the rows several times but eventually Notepad ran out of memory as well

Upvotes: 0

Dan Donoghue
Dan Donoghue

Reputation: 6206

Based on Pauls description of what your code does, this may work for you, it did for my own test data:

Sub Quickcopy()
Rows(29).Insert 'Make sure there is a blank row there
With Range("A30:D" & 280000) '280000 = 14 rows multiplied by your number of copies. Change D to however far the columns go
    .Formula = "=IF(A16="""","""",A16)" 'Had to do this otherwise a straight =A16 returned 0 where blanks exist. Note Excel is smart enough to increment the row ref as it goes
    .Copy 'Copy
    .PasteSpecial xlPasteValues 'Paste values
End With
End Sub

Upvotes: 1

Related Questions