Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Ускорение макроса - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Ускорение макроса (Макросы/Sub)
Ускорение макроса
tasdel Дата: Среда, 26.02.2025, 19:44 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 148
Репутация: 0 ±
Замечаний: 20% ±

Excel 2007
Здравствуйте уважаемые колдуны и шаманы мс/ексель. Я собственно ручно нахимичил макрос, он функции свои выполняет четенько, но тугой и долгий...
Вы можете поколдовать, и сделать из него нормальный человеческий код. Макрос работает приблизительно 1,3 минуты. Я предполагаю, что у меня на работе старенький компьютер из-за него греется.
Заранее спасибо!!!

[vba]
Код
Private Sub CommandButton1_Click()
If OptionButton1.Value = True Then '''''''''''''''''''''''''''''''''''''''''''''''''''
Da = MsgBox("Сформировать табель?", vbYesNo, "")
If Da = vbYes Then
Unload Me
UserForm3.Show vbModeless
Application.ScreenUpdating = False
n = 0
While Worksheets(1).Cells(n + 7, 48).Value <> ""
n = n + 1
Wend
For I = 7 To n + 6
If Worksheets(1).Cells(I, 46).Value = 0 Then
    Worksheets(1).Cells(I, 40).Value = "del"
    Worksheets(1).Cells(1 + I, 40).Value = "del"
    Worksheets(1).Cells(2 + I, 40).Value = "del"
    Worksheets(1).Cells(3 + I, 40).Value = "del"
    Worksheets(1).Cells(4 + I, 40).Value = "del"
    Worksheets(1).Cells(5 + I, 40).Value = "del"
End If
Next

Worksheets(1).Range("AN700:AN703") = "*"
Worksheets(1).Range("A1:AP703").Copy Worksheets(3).Range("A1:AP703")
Worksheets(1).Range("AS7:AS703").Copy Worksheets(3).Range("AS7:AS703")
Worksheets(3).Range("A1:AP703").Value = Worksheets(3).Range("A1:AP703").Value
Worksheets(3).Rows("7:703").RowHeight = 27.5
Worksheets(3).Range("A1:AP703").Font.Bold = False
Worksheets(3).Range("A1:AP703").Font.ColorIndex = 1
Worksheets(3).Range("B7:B703").Interior.ColorIndex = xlNone
Worksheets(3).PageSetup.PrintArea = "$A$1:$AP$703"

  lastRow = Worksheets(3).UsedRange.Row - 1 + Worksheets(3).UsedRange.Rows.Count
      Application.ScreenUpdating = False
       For r = lastRow To 7 Step -1
          If Worksheets(3).Cells(r, 40).Value = "del" Then Worksheets(3).Rows(r).Delete
          If Worksheets(3).Cells(r, 45).Value = 0 Then Worksheets(3).Rows(r).Delete
       Next r
       
      
n = 0
While Worksheets(1).Cells(n + 7, 48).Value <> ""
n = n + 1
Wend
For I = 7 To n + 6

If Worksheets(3).Cells(I, 40).Value = "*" Then
   Worksheets(3).Cells(I, 40).Value = ""
End If
If Worksheets(1).Cells(I, 40).Value = "del" Then
   Worksheets(1).Cells(I, 40).Value = ""
End If
Next
Worksheets(1).Range("AN700:AN703") = ""
Worksheets(3).Range("AN700:AN703") = ""
Worksheets(3).Range("C6:AG6").ClearContents
Worksheets(3).Range("AS7:AS703").ClearContents
Worksheets(3).Range("R6").Value = 3
Application.ScreenUpdating = True
Unload UserForm3
Worksheets(3).Activate
Worksheets(3).Range("AQ1").Select
End If
End If
End Sub
[/vba]
 
Ответить
СообщениеЗдравствуйте уважаемые колдуны и шаманы мс/ексель. Я собственно ручно нахимичил макрос, он функции свои выполняет четенько, но тугой и долгий...
Вы можете поколдовать, и сделать из него нормальный человеческий код. Макрос работает приблизительно 1,3 минуты. Я предполагаю, что у меня на работе старенький компьютер из-за него греется.
Заранее спасибо!!!

[vba]
Код
Private Sub CommandButton1_Click()
If OptionButton1.Value = True Then '''''''''''''''''''''''''''''''''''''''''''''''''''
Da = MsgBox("Сформировать табель?", vbYesNo, "")
If Da = vbYes Then
Unload Me
UserForm3.Show vbModeless
Application.ScreenUpdating = False
n = 0
While Worksheets(1).Cells(n + 7, 48).Value <> ""
n = n + 1
Wend
For I = 7 To n + 6
If Worksheets(1).Cells(I, 46).Value = 0 Then
    Worksheets(1).Cells(I, 40).Value = "del"
    Worksheets(1).Cells(1 + I, 40).Value = "del"
    Worksheets(1).Cells(2 + I, 40).Value = "del"
    Worksheets(1).Cells(3 + I, 40).Value = "del"
    Worksheets(1).Cells(4 + I, 40).Value = "del"
    Worksheets(1).Cells(5 + I, 40).Value = "del"
End If
Next

Worksheets(1).Range("AN700:AN703") = "*"
Worksheets(1).Range("A1:AP703").Copy Worksheets(3).Range("A1:AP703")
Worksheets(1).Range("AS7:AS703").Copy Worksheets(3).Range("AS7:AS703")
Worksheets(3).Range("A1:AP703").Value = Worksheets(3).Range("A1:AP703").Value
Worksheets(3).Rows("7:703").RowHeight = 27.5
Worksheets(3).Range("A1:AP703").Font.Bold = False
Worksheets(3).Range("A1:AP703").Font.ColorIndex = 1
Worksheets(3).Range("B7:B703").Interior.ColorIndex = xlNone
Worksheets(3).PageSetup.PrintArea = "$A$1:$AP$703"

  lastRow = Worksheets(3).UsedRange.Row - 1 + Worksheets(3).UsedRange.Rows.Count
      Application.ScreenUpdating = False
       For r = lastRow To 7 Step -1
          If Worksheets(3).Cells(r, 40).Value = "del" Then Worksheets(3).Rows(r).Delete
          If Worksheets(3).Cells(r, 45).Value = 0 Then Worksheets(3).Rows(r).Delete
       Next r
       
      
n = 0
While Worksheets(1).Cells(n + 7, 48).Value <> ""
n = n + 1
Wend
For I = 7 To n + 6

If Worksheets(3).Cells(I, 40).Value = "*" Then
   Worksheets(3).Cells(I, 40).Value = ""
End If
If Worksheets(1).Cells(I, 40).Value = "del" Then
   Worksheets(1).Cells(I, 40).Value = ""
End If
Next
Worksheets(1).Range("AN700:AN703") = ""
Worksheets(3).Range("AN700:AN703") = ""
Worksheets(3).Range("C6:AG6").ClearContents
Worksheets(3).Range("AS7:AS703").ClearContents
Worksheets(3).Range("R6").Value = 3
Application.ScreenUpdating = True
Unload UserForm3
Worksheets(3).Activate
Worksheets(3).Range("AQ1").Select
End If
End If
End Sub
[/vba]
Автор - tasdel
Дата добавления - 26.02.2025 в 19:44
capp2104 Дата: Среда, 26.02.2025, 20:37 | Сообщение № 2
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: 1 ±
Замечаний: 0% ±

2016
[vba]
Код
Private Sub CommandButton1_Click()
If OptionButton1.Value = True Then
If MsgBox("Сформировать табель?", vbYesNo, "") <> vbYes Then Exit Sub

'Отключаем все возможные "тормоза"
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

Unload Me
UserForm3.Show vbModeless

Dim ws1 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets(1)
Set ws3 = Worksheets(3)

'Определение последней строки через Find (быстрее чем цикл)
Dim lastRow As Long
lastRow = ws1.Cells(ws1.Rows.Count, 48).End(xlUp).Row

'Обработка данных на листе 1
Dim delRange As Range
For i = 7 To lastRow
If ws1.Cells(i, 46).Value = 0 Then
If delRange Is Nothing Then
Set delRange = ws1.Range(ws1.Cells(i, 40), ws1.Cells(i + 5, 40))
Else
Set delRange = Union(delRange, ws1.Range(ws1.Cells(i, 40), ws1.Cells(i + 5, 40)))
End If
End If
Next i
If Not delRange Is Nothing Then delRange.Value = "del"

'Перенос данных на лист3
ws1.Range("A1:AP703").Copy
ws3.Range("A1").PasteSpecial xlPasteValues
ws1.Range("AS7:AS703").Copy
ws3.Range("AS7").PasteSpecial xlPasteValues

'Очистка буфера обмена и настройки листа
Application.CutCopyMode = False
With ws3
.Range("AN700:AN703").Value = "*"
.Rows("7:703").RowHeight = 27.5
.Range("A1:AP703").Font.Bold = False
.Range("A1:AP703").Font.ColorIndex = 1
.Range("B7:B703").Interior.ColorIndex = xlNone
.PageSetup.PrintArea = "$A$1:$AP$703"
End With

'Удаление строк в обратном порядке
Dim r As Long
lastRow = ws3.UsedRange.Row + ws3.UsedRange.Rows.Count - 1
For r = lastRow To 7 Step -1
If ws3.Cells(r, 40).Value = "del" Or ws3.Cells(r, 45).Value = 0 Then
ws3.Rows(r).Delete
End If
Next r

'Финализация данных
With ws3
.Range("AN700:AN703").ClearContents
.Range("C6:AG6").ClearContents
.Range("AS7:AS703").ClearContents
.Range("R6").Value = 3
End With

'Восстанавливаем настройки
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With

Unload UserForm3
ws3.Activate
ws3.Range("AQ1").Select
End If
End Sub
[/vba]


Сообщение отредактировал Pelena - Воскресенье, 02.03.2025, 14:53
 
Ответить
Сообщение[vba]
Код
Private Sub CommandButton1_Click()
If OptionButton1.Value = True Then
If MsgBox("Сформировать табель?", vbYesNo, "") <> vbYes Then Exit Sub

'Отключаем все возможные "тормоза"
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

Unload Me
UserForm3.Show vbModeless

Dim ws1 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets(1)
Set ws3 = Worksheets(3)

'Определение последней строки через Find (быстрее чем цикл)
Dim lastRow As Long
lastRow = ws1.Cells(ws1.Rows.Count, 48).End(xlUp).Row

'Обработка данных на листе 1
Dim delRange As Range
For i = 7 To lastRow
If ws1.Cells(i, 46).Value = 0 Then
If delRange Is Nothing Then
Set delRange = ws1.Range(ws1.Cells(i, 40), ws1.Cells(i + 5, 40))
Else
Set delRange = Union(delRange, ws1.Range(ws1.Cells(i, 40), ws1.Cells(i + 5, 40)))
End If
End If
Next i
If Not delRange Is Nothing Then delRange.Value = "del"

'Перенос данных на лист3
ws1.Range("A1:AP703").Copy
ws3.Range("A1").PasteSpecial xlPasteValues
ws1.Range("AS7:AS703").Copy
ws3.Range("AS7").PasteSpecial xlPasteValues

'Очистка буфера обмена и настройки листа
Application.CutCopyMode = False
With ws3
.Range("AN700:AN703").Value = "*"
.Rows("7:703").RowHeight = 27.5
.Range("A1:AP703").Font.Bold = False
.Range("A1:AP703").Font.ColorIndex = 1
.Range("B7:B703").Interior.ColorIndex = xlNone
.PageSetup.PrintArea = "$A$1:$AP$703"
End With

'Удаление строк в обратном порядке
Dim r As Long
lastRow = ws3.UsedRange.Row + ws3.UsedRange.Rows.Count - 1
For r = lastRow To 7 Step -1
If ws3.Cells(r, 40).Value = "del" Or ws3.Cells(r, 45).Value = 0 Then
ws3.Rows(r).Delete
End If
Next r

'Финализация данных
With ws3
.Range("AN700:AN703").ClearContents
.Range("C6:AG6").ClearContents
.Range("AS7:AS703").ClearContents
.Range("R6").Value = 3
End With

'Восстанавливаем настройки
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With

Unload UserForm3
ws3.Activate
ws3.Range("AQ1").Select
End If
End Sub
[/vba]
Автор - capp2104
Дата добавления - 26.02.2025 в 20:37
tasdel Дата: Среда, 26.02.2025, 21:02 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 148
Репутация: 0 ±
Замечаний: 20% ±

Excel 2007
Эта строка закрашивается желтым и выдает ошибку - 1004.Пишет ячейки должны иметь одинаковый размер
[vba]
Код
ws3.Range("A1").PasteSpecial xlPasteValues
[/vba]
 
Ответить
СообщениеЭта строка закрашивается желтым и выдает ошибку - 1004.Пишет ячейки должны иметь одинаковый размер
[vba]
Код
ws3.Range("A1").PasteSpecial xlPasteValues
[/vba]
Автор - tasdel
Дата добавления - 26.02.2025 в 21:02
tasdel Дата: Среда, 26.02.2025, 21:18 | Сообщение № 4
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 148
Репутация: 0 ±
Замечаний: 20% ±

Excel 2007
На Лист1 и на Лист3 ячейки имеют разные размеры. Лист1 - рабочий, Лист3 - для печати.
 
Ответить
СообщениеНа Лист1 и на Лист3 ячейки имеют разные размеры. Лист1 - рабочий, Лист3 - для печати.
Автор - tasdel
Дата добавления - 26.02.2025 в 21:18
tasdel Дата: Среда, 26.02.2025, 21:36 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 148
Репутация: 0 ±
Замечаний: 20% ±

Excel 2007
Поубирал я [vba]
Код
PasteSpecial xlPasteValues
[/vba] и сделал копирование на прямую. С циклами макрос работает на 5 сек дольше. Спасибо за помощь.
Буду мудрить что-то другое.
 
Ответить
СообщениеПоубирал я [vba]
Код
PasteSpecial xlPasteValues
[/vba] и сделал копирование на прямую. С циклами макрос работает на 5 сек дольше. Спасибо за помощь.
Буду мудрить что-то другое.
Автор - tasdel
Дата добавления - 26.02.2025 в 21:36
Pelena Дата: Четверг, 27.02.2025, 09:07 | Сообщение № 6
Группа: Админы
Ранг: Местный житель
Сообщений: 19456
Репутация: 4580 ±
Замечаний: ±

Excel 365 & Mac Excel
tasdel, собственный макрос - это хорошо, но хотелось бы знать суть/цель задачи. И приложите файл с небольшим примером
Например, эти строчки
[vba]
Код
    Worksheets(1).Cells(I, 40).Value = "del"
    Worksheets(1).Cells(1 + I, 40).Value = "del"
    Worksheets(1).Cells(2 + I, 40).Value = "del"
    Worksheets(1).Cells(3 + I, 40).Value = "del"
    Worksheets(1).Cells(4 + I, 40).Value = "del"
    Worksheets(1).Cells(5 + I, 40).Value = "del"
[/vba]
можно заменить одной
[vba]
Код
Worksheets(1).Cells(I, 40).Resize(6).Value = "del"
[/vba]

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
Сообщениеtasdel, собственный макрос - это хорошо, но хотелось бы знать суть/цель задачи. И приложите файл с небольшим примером
Например, эти строчки
[vba]
Код
    Worksheets(1).Cells(I, 40).Value = "del"
    Worksheets(1).Cells(1 + I, 40).Value = "del"
    Worksheets(1).Cells(2 + I, 40).Value = "del"
    Worksheets(1).Cells(3 + I, 40).Value = "del"
    Worksheets(1).Cells(4 + I, 40).Value = "del"
    Worksheets(1).Cells(5 + I, 40).Value = "del"
[/vba]
можно заменить одной
[vba]
Код
Worksheets(1).Cells(I, 40).Resize(6).Value = "del"
[/vba]
Автор - Pelena
Дата добавления - 27.02.2025 в 09:07
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Ускорение макроса (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2025 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!