Макрос не может закончить, мой лист слишком большой?

Question

Я пытался запустить то, что, как я думал, был простым макросом в течение двух дней, и продолжает работать в этой ошибке:

«Excel не может выполнить эту задачу с доступными ресурсами. Выберите меньшее количество данных или закройте другие приложения».

Я хотел бы получить 20 000 итераций из макроса, но ошибка появляется быстрее раньше. Я думаю, что он останавливается около 5000 человек. Хуже всего то, что я не могу сохранить то, что я получаю после. Я знаю, что после этого много итераций есть несколько большое количество данных, но нигде не заполняется весь лист. Я хотел бы иметь возможность запускать макрос, а затем оптимизировать весы вправо.

Код:

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 

Образец данных:

К сожалению, я забыл опубликовать ссылку на книгу:

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

Answer 1

Ваш код копирует все данные из строки 16-28, для 20 000 раз, с и пустая строка между наборами.

Этот код выполняет ту же операцию (примерно 1 минуту):

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 

.

Примечания:

• Он генерирует 280,028 строк с 423 столбцов так, вы должны сохранить его как .xlsb:

  • .xlsm: размер файла 772 Мб - 5 мин, чтобы сэкономить, 3 мин, чтобы открыть

  • .xlsb: размер файла 475 Мб - 1 мин, чтобы сэкономить, 1 мин, чтобы открыть

.

Edit:

Я изменил код, чтобы скопировать .Formula вместо .Value2 и побежал в том же номере:

• Excel запускается из памяти, когда я = 1,276 (заполненные строки: 17,882)
• 13 рядов X 421 столбцов = 5 473 ячейки, в общей сложности 4 979 формул
• Задача Mgr: Excel.ехе - Память (Private Working Set): 1833524 Кб (из памяти)

• Application.Calculation = xlCalculationManual не решает проблему

• Я также попытался запустить код 1000 итераций, а затем вручную скопировать и вставить более 20 раз

  • Он выбежал из памяти («Excel не может выполнить эту задачу с имеющимися ресурсами ...»)

• Последней попыткой была в Notepad ++, чтобы исключить из расчетов предпоса с

  • В Excel: Формулы -> Показать Формулы (в формуле аудита раздела), а затем скопировать
  • В Блокнот: паста формул
  • Копирование строки от 16 до 28 + пустой строке
  • Pasted строки несколько раз, но в конечном счете Notepad выбежал из памяти, а также

Answer 2

Основываясь на описании Паулс того, что делает ваш код, это может работать для вас, это сделал для мои собственные данные теста:

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