Оптимижация работы макроса

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Оптимижация работы макроса (Макросы/Sub)

niru1980

Дата: Воскресенье, 15.06.2014, 16:04 | Сообщение № 1

Группа: Пользователи

Ранг: Новичок

Сообщений: 38

Репутация: 1 ±

Замечаний: 0% ±

Excel 2010

При выполнении макроса выскакивает ошибка "недостаточно ресурсов выберите меньше данных или закройте другие приложения"
так как размер файла в архиве получается более 100 кб выложить файл немогу

[vba]

Код

Sub Макрос1()
Application.ScreenUpdating = False
' Макрос1 Макрос
'
' Сочетание клавиш: Ctrl+м
'
        ActiveSheet.Range("$A$4:$AX$9967").AutoFilter Field:=3, Criteria1:=">1", _
         Operator:=xlAnd, Criteria2:="<1.31"
     ActiveWindow.SmallScroll Down:=-6
     Sheets("1-1.3").Select
     ActiveWindow.SmallScroll Down:=-21
     Cells.Select
     Selection.ClearContents
     Sheets("Лист1").Select
     Cells.Select
     Range("B8").Activate
     Selection.Copy
     Sheets("1-1.3").Select

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

     Sheets("Лист1").Select
     ActiveSheet.Range("$A$4:$AX$9967").AutoFilter Field:=3, Criteria1:=">1.3", _
         Operator:=xlAnd, Criteria2:="<1.61"
     Application.CutCopyMode = False
     Selection.Copy
     Sheets("1.31-1.6").Select
     Cells.Select
     Range("A2").Activate

     Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
         False, Transpose:=False
     Sheets("Лист1").Select

      Sheets("Лист1").Select
     ActiveSheet.Range("$A$4:$AX$9967").AutoFilter Field:=3, Criteria1:=">1.6", _
         Operator:=xlAnd, Criteria2:="<1.71"
     Application.CutCopyMode = False
     Selection.Copy
     Sheets("1.61-1.7").Select
     Cells.Select
     Range("A2").Activate

     Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
         False, Transpose:=False
     Sheets("Лист1").Select
     Application.ScreenUpdating = True '

     End Sub
     Sub Макрос2()
Application.ScreenUpdating = False
'
' Макрос1 Макрос
'
' Сочетание клавиш: Ctrl+и

      Sheets("Лист1").Select
     ActiveSheet.Range("$A$4:$AX$9967").AutoFilter Field:=3, Criteria1:=">1.7", _
         Operator:=xlAnd, Criteria2:="<1.81"
     Application.CutCopyMode = False
     Selection.Copy
     Sheets("1.71-1.8").Select
     Cells.Select
     Range("A2").Activate

     Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
         False, Transpose:=False
     Sheets("Лист1").Select

      Sheets("Лист1").Select
     ActiveSheet.Range("$A$4:$AX$9967").AutoFilter Field:=3, Criteria1:=">1.8", _
         Operator:=xlAnd, Criteria2:="<1.91"
     Application.CutCopyMode = False
     Selection.Copy
     Sheets("1.81-1.9").Select
     Cells.Select
     Range("A2").Activate

     Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
         False, Transpose:=False
     Sheets("Лист1").Select

      Sheets("Лист1").Select
     ActiveSheet.Range("$A$4:$AX$9967").AutoFilter Field:=3, Criteria1:=">1.9", _
         Operator:=xlAnd, Criteria2:="<2.01"
     Application.CutCopyMode = False
     Selection.Copy
     Sheets("1.91-2").Select
     Cells.Select
     Range("A2").Activate

     Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
         False, Transpose:=False
     Sheets("Лист1").Select
Application.ScreenUpdating = True '

     End Sub
     Sub Макрос3()
     Application.ScreenUpdating = False
'
' Макрос1 Макрос
'
' Сочетание клавиш: Ctrl+т

      Sheets("Лист1").Select
     ActiveSheet.Range("$A$4:$AX$9967").AutoFilter Field:=3, Criteria1:=">2", _
         Operator:=xlAnd, Criteria2:="<2.11"
     Application.CutCopyMode = False
     Selection.Copy
     Sheets("2.01-2.1").Select
     Cells.Select
     Range("A2").Activate

     Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
     Sheets("Лист1").Select

     Sheets("Лист1").Select
     ActiveSheet.Range("$A$4:$AX$9967").AutoFilter Field:=3, Criteria1:=">2.1", _
         Operator:=xlAnd, Criteria2:="<2.21"
     Application.CutCopyMode = False
     Selection.Copy
     Sheets("2.11-2.2").Select
     Cells.Select
     Range("A2").Activate

     Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
         False, Transpose:=False
     Sheets("Лист1").Select

     Sheets("Лист1").Select
     ActiveSheet.Range("$A$4:$AX$9967").AutoFilter Field:=3, Criteria1:=">2.2", _
         Operator:=xlAnd, Criteria2:="<2.31"
     Application.CutCopyMode = False
     Selection.Copy
     Sheets("2.21-2.3").Select
     Cells.Select
     Range("A2").Activate

     Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
         False, Transpose:=False
     Sheets("Лист1").Select
Application.ScreenUpdating = True '

     End Sub

[/vba]

Код

[/vba]niru1980

Ответить

СообщениеПри выполнении макроса выскакивает ошибка "недостаточно ресурсов выберите меньше данных или закройте другие приложения"
так как размер файла в архиве получается более 100 кб выложить файл немогу

[vba]

Код

[/vba]

Автор - niru1980
Дата добавления - 15.06.2014 в 16:04

niru1980

Дата: Воскресенье, 15.06.2014, 16:06 | Сообщение № 2

Группа: Пользователи

Ранг: Новичок

Сообщений: 38

Репутация: 1 ±

Замечаний: 0% ±

Excel 2010

подскажите пожалуйста как после выполнения копирования данных на новый лист очистить память Excel 2007

Ответить

nilem

Дата: Воскресенье, 15.06.2014, 19:08 | Сообщение № 3

Группа: Авторы

Ранг: Старожил

Сообщений: 1613

Репутация: 563 ±

Замечаний: 0% ±

Excel 2013, 2016

попробуйте вот в таком виде
[vba]

Код

Sub Macro1()
Application.ScreenUpdating = False
With Sheets("Лист1").Range("$A$4:$AX$9967")
     .AutoFilter Field:=3, Criteria1:=">1.7", _
                 Operator:=xlAnd, Criteria2:="<1.81"
     .Copy Sheets("1.71-1.8").Range("A2") 'при таком копировании специально очищать память не нужно
     .AutoFilter
End With
Application.ScreenUpdating = True
End Sub

[/vba]

Яндекс.Деньги 4100159601573

Ответить

niru1980

Дата: Воскресенье, 15.06.2014, 19:22 | Сообщение № 4

Группа: Пользователи

Ранг: Новичок

Сообщений: 38

Репутация: 1 ±

Замечаний: 0% ±

Excel 2010

nilem, спасибо тема закрыта все заработало

Ответить

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Оптимижация работы макроса (Макросы/Sub)

Страница 1 из 1
1