Скрыть работу скрипта

[blackeangel]

Всем привет, помогите скрыть работу скрипта, а то при добавлении листа прыгает и стандартными средствами не скрывает.

Application.ScreenUpdating = False
Application.ScreenUpdating = true

не предлагать - не работают.
А так же если есть возможность, то помочь оптимизировать код. Сам код:

Sub All_in_one()
Application.ScreenUpdating = False
'On Error Resume Next
viravnivanie 'выравниваем по содержимому
'готовим сборки для заноса в диспетчер
Cells.Find(What:="Сборка", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns).Activate
ncolumn2 = ActiveCell.Column
Columns(ncolumn2).Copy
Sheets.Add After:=Sheets(ActiveSheet.Index)
ActiveSheet.Name = "Сборки для диспетчера"
ActiveSheet.Paste
ActiveSheet.UsedRange.RemoveDuplicates Columns:=ncolumn2, Header:=xlYes 'удаляем дубли по найденой выше колонке
'заменяем для удобности ВО ВСЕЙ КНИГЕ!
'For Each sh In Sheets
' sh.Cells.Replace "Сборка", "№ сборки"
'Next
'заменяем для удобности НА ТЕКУЩЕМ ЛИСТЕ!
Cells.Replace What:="Сборка", Replacement:="№ сборки", LookAt:=xlWhole, _
SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
viravnivanie 'выравниваем по содержимому

'Sheets.Add After:=Sheets(Sheets.Count) 'вставляем новый лист после текущего

Worksheets(1).Copy After:=Sheets(Worksheets(1).Index) 'вставляем дубликат активного листа после текущего
ActiveSheet.Name = "Рабочий" 'задаем имя
Columns("E:R").Delete 'Удаляем лишнее
'ищем колонку по обозначению
Cells.Find(What:="Обозначение", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns).Activate
ncolumn = ActiveCell.Column
ActiveSheet.UsedRange.RemoveDuplicates Columns:=ncolumn, Header:=xlYes 'удаляем дубли по найденой выше колонке

ActiveSheet.UsedRange.AutoFilter 'ставим автофильтр
viravnivanie 'выравниваем по содержимому
Cexnalist 'цеха на лист ()

Sheets("Рабочий").Activate

Application.ScreenUpdating = True
End Sub
Sub Cexnalist()
Application.ScreenUpdating = False 'тормозим отображение на экране
'On Error Resume Next
NetKD 'нет КД
Sheets("Рабочий").Activate
ActiveSheet.ShowAllData 'сбрасываем автофильтр
'фильтруем по МЦ+СМЦ
Sheets("Рабочий").UsedRange.AutoFilter Field:=7, Criteria1:="=МЦ", _
Operator:=xlOr, Criteria2:="=СМЦ"
Sheets("Рабочий").UsedRange.Copy 'копируем отфильтрованное
Range("A1").Select 'сбрасываем выделение
Sheets.Add After:=Sheets(Sheets("Рабочий").Index + 2) 'Вставляем лист через 1
ActiveSheet.Name = "МЦ+СМЦ" 'задаем имя нового листа
ActiveSheet.Paste 'вставляем скопированное
ActiveSheet.UsedRange.AutoFilter 'ставим автофильтр
viravnivanie 'выравниваем по содержимому

Sheets("Рабочий").Activate
Sheets("Рабочий").UsedRange.AutoFilter Field:=7, Criteria1:="ЭМЦ"
Sheets("Рабочий").UsedRange.Copy 'копируем отфильтрованное
Range("A1").Select
Sheets.Add After:=Sheets(Sheets("Рабочий").Index + 3)
ActiveSheet.Name = "ЭМЦ"
ActiveSheet.Paste
ActiveSheet.UsedRange.AutoFilter 'ставим автофильтр
viravnivanie 'выравниваем по содержимому

Sheets("Рабочий").ShowAllData 'сбрасываем автофильтр

askDialog 'Печатаем всё

Application.ScreenUpdating = True
End Sub
Sub NetKD() 'нет КД
Application.ScreenUpdating = False
'On Error Resume Next
Sheets("Рабочий").Activate
'отфильтровываем только пустые
ActiveSheet.UsedRange.AutoFilter Field:=3, Criteria1:="="
ActiveSheet.UsedRange.AutoFilter Field:=4, Criteria1:="="
ActiveSheet.UsedRange.Copy 'копируем отфильтрованное
Range("A1").Select
Sheets.Add After:=Sheets(Sheets("Рабочий").Index + 1)
ActiveSheet.Name = "Без КД"
ActiveSheet.Paste
Columns("C:R").Delete 'Удаляем лишнее
viravnivanie 'выравниваем по содержимому
Application.ScreenUpdating = True
End Sub


Sub viravnivanie() 'выравниваем по содержимому
Application.ScreenUpdating = False
ActiveSheet.UsedRange.Select
With Selection
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Columns.AutoFit
'крепим верхнюю строку
ActiveSheet.Rows(2).Select
ActiveWindow.FreezePanes = True
Range("A1").Select
'сквозные строки
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.708661417322835)
.RightMargin = Application.InchesToPoints(0.708661417322835)
.TopMargin = Application.InchesToPoints(0.748031496062992)
.BottomMargin = Application.InchesToPoints(0.748031496062992)
.HeaderMargin = Application.InchesToPoints(0.31496062992126)
.FooterMargin = Application.InchesToPoints(0.31496062992126)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
Application.ScreenUpdating = True
End Sub
Sub askDialog() 'запрос на печать
ask = MsgBox("Распечатать?", vbYesNo, "Печать")
If ask = 6 Then
Sheets("ЭМЦ").Copy After:=Sheets(Sheets("ЭМЦ").Index) 'вставляем дубликат активного листа после текущего
Columns(3).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 'Пустые строки для МСК
'отфильтровываем только пустые
ActiveSheet.UsedRange.AutoFilter Field:=4, Criteria1:="="
ActiveSheet.UsedRange.AutoFilter Field:=5, Criteria1:="="
Range("2:" & Rows.Count).Delete 'удаляем все, кроме 2 строки
ActiveSheet.ShowAllData 'сбрасываем автофильтр
'Сортируем по сборке
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Range( _
"A1:A50000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
viravnivanie 'выравниваем по содержимому
'удаляем без вопросов
Application.DisplayAlerts = False
Sheets(Sheets("ЭМЦ").Index + 1).Delete
Application.DisplayAlerts = True

Sheets("МЦ+СМЦ").Copy After:=Sheets(Sheets("МЦ+СМЦ").Index) 'вставляем дубликат активного листа после текущего
'отфильтровываем только пустые
ActiveSheet.UsedRange.AutoFilter Field:=3, Criteria1:="="
ActiveSheet.UsedRange.AutoFilter Field:=4, Criteria1:="="
Range("2:" & Rows.Count).Delete 'удаляем все, кроме 2 строки
ActiveSheet.ShowAllData 'сбрасываем автофильтр
'Сортируем по сборке
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Range( _
"A1:A50000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveSheet.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
viravnivanie 'выравниваем по содержимому
'удаляем без вопросов
Application.DisplayAlerts = False
Sheets(Sheets("МЦ+СМЦ").Index + 1).Delete
Application.DisplayAlerts = True
Else
Exit Sub
End If
End Sub

[Iska]

не предлагать - не работают. »
В чём именно заключается «не работа»? В том, что Вы не к месту применяете «Application.ScreenUpdating = True»?!

[blackeangel]

не предлагать - не работают. »
В чём именно заключается «не работа»? В том, что Вы не к месту применяете «Application.ScreenUpdating = True»?!
Так скажите как будет к месту?
Если оставить только в All in one () то результат тот же, прыгают и скачут листы.

[Iska]

Покажите документ. Опишите работу.

[blackeangel]

Покажите документ. Опишите работу.
Исходный Лист Sheet, все последующие создает макрос.
Что надо сделать, точнее что уже сделал я:
1. Создать дубль листа под названием "Рабочий" (и на каждом листе должны быть сквозные строки, отформатировано по ширине и высоте по содержимому, стоять автофильтр)
2. Удалить дубликаты по "Обозначение" и отрезать все до "Маршрут" справа(начиная с столбца E и все что правее)
3. На отдельный лист вынести Столбец "Сборки" и удалить дубликаты, назвать "Сборки для диспетчера", переименовать заголовок с "Сборка" на "№ сборки"
4. На отдельный лист вынести что имеет в столбце "цех" ЭМЦ и назвать "ЭМЦ"
5. На отдельный лист вынести что имеет в столбце "цех" СМЦ и МЦ и назвать "МЦ+СМЦ"
6. На отдельный лист вынести все что не содержит пусто по столбцам "Карточки" и "ПредвАрхив" и назвать "Без КД"
7. Отправить по почте лист "Нет КД", не вложением, а заполнив тело сообщения содержимым листа "Нет КД", с переменным отправителем, название темы сообщения берется с названия листа(этот пункт в планах еще, тк не знаю как заполнить тело письма)

[Iska]

blackeangel, я не придираюсь. Но я предполагаю, что я увижу в выложенном а) Рабочую книгу с б) макросами, с указанием: запускаем макрос XYZ() — наблюдаем описанную:
Если оставить только в All in one () то результат тот же, прыгают и скачут листы. »
проблему. При этом код, как минимум, не будет содержать ошибок времени исполнения.

[Iska]

Я взял Ваш код из сообщения #1 и поместил его в Вашу Рабочую книгу из сообщения #5. Удалил из оной Рабочей книги все листы, кроме «Sheet». Закомментировал:

все упоминания «Application.ScreenUpdating», кроме как в начале (=False) и в конце (=True) процедуры «All_in_one()»;
все отсутствующие и потому не работающие в моей версии Office объекты/методы/свойства;
все прочие оставшиеся ошибки времени исполнения, не вызванные отсутствующими объектами/методами/свойствами.

Вызвал из Рабочей книги исполнение процедуры «All_in_one()». Никаких прыжков/скачков листов во время исполнения кода не увидел.

[blackeangel]

Я взял Ваш код из сообщения #1 и поместил его в Вашу Рабочую книгу из сообщения #5. Удалил из оной Рабочей книги все листы, кроме «Sheet». Закомментировал:

все упоминания «Application.ScreenUpdating», кроме как в начале (=False) и в конце (=True) процедуры «All_in_one()»;
все отсутствующие и потому не работающие в моей версии Office объекты/методы/свойства;
все прочие оставшиеся ошибки времени исполнения, не вызванные отсутствующими объектами/методами/свойствами.

Вызвал из Рабочей книги исполнение процедуры «All_in_one()». Никаких прыжков/скачков листов во время исполнения кода не увидел.
Хорошо. Можно этот код как то переписать избегая перехода на листы?
Просто некоторые Sub используются отдельно в надстройке как самостоятельные и из них выкинуть Application.ScreenUpdating никак.

[blackeangel]

при создании листа или его дубликата он по умолчанию активен. Вот как это побороть?

[a_axe]

при создании листа или его дубликата он по умолчанию активен. Вот как это побороть? »
например так:
Dim DefaultActiveSheet As Worksheet
Set DefaultActiveSheet = ActiveWorkbook.ActiveSheet
ActiveWorkbook.Sheets.Add
DefaultActiveSheet.Activate
Set DefaultActiveSheet = Nothing

[blackeangel]

a_axe, а теперь поясните что тут делает код?

[a_axe]

Как-то так:

Dim DefaultActiveSheet As Worksheet - определяем переменную, в которую позже сохраним тот лист, который является активным при работе программы.

Set DefaultActiveSheet = ActiveWorkbook.ActiveSheet - сохраняем лист, который является активным на данный момент в переменную, чтобы сделать его активным при необходимости.

ActiveWorkbook.Sheets.Add - добавляем в рабочую книгу еще один лист. Он действительно становится активным.

DefaultActiveSheet.Activate - обращаемся к сохраненному листу, который был активным изначально, и перестал быть активным после добавления листа в книгу. Делаем его активным снова.

Set DefaultActiveSheet = Nothing - выгружаем значение переменной из памяти, т.к. оно больше не нужно.

[blackeangel]

А создать сразу неактивный никак? Просто все равно если нет скринапдатера то все это видно будет. Или я ошибаюсь?

[a_axe]

А создать сразу неактивный никак? »
Поиск ничего не дал, мне способ не известен.
Просто все равно если нет скринапдатера то все это видно будет. »
Попробуйте с вашим файлом - у меня мигает рабочий лист на долю секунды. Насколько это критично, вам виднее, мне кажется пользователь даже понять ничего не успеет.

[blackeangel]

А создать сразу неактивный никак? »
Поиск ничего не дал, мне способ не известен.
Просто все равно если нет скринапдатера то все это видно будет. »
Попробуйте с вашим файлом - у меня мигает рабочий лист на долю секунды. Насколько это критично, вам виднее, мне кажется пользователь даже понять ничего не успеет.

Искать то искал сам, тоже ничего не нашел. А если создать сразу скрытый лист?и как это сделать?

[Iska]

Просто некоторые Sub используются отдельно в надстройке как самостоятельные и из них выкинуть Application.ScreenUpdating никак. »
А придётся с этим что-то делать. Можете, например, при вызове передавать в такие процедуры параметр, определяющий потребность исполнять в ней в данном вызове «Application.ScreenUpdating». Но смотрите сами, я весь Ваш код не вижу, не могу сказать, как будет лучше.

[blackeangel]

Просто некоторые Sub используются отдельно в надстройке как самостоятельные и из них выкинуть Application.ScreenUpdating никак. »
А придётся с этим что-то делать. Можете, например, при вызове передавать в такие процедуры параметр, определяющий потребность исполнять в ней в данном вызове «Application.ScreenUpdating».
Это как?

[Iska]

Например, так:
Option Explicit

Sub MainSub()
Application.ScreenUpdating = False

Call SomeSub(bScreenUpdate:=False)

If Application.ScreenUpdating = False Then
Application.ScreenUpdating = True
End If
End Sub

Sub OtherSub()
Call SomeSub
End Sub

Sub SomeSub(Optional bScreenUpdate As Boolean = True)
Debug.Print bScreenUpdate, Application.ScreenUpdating

If bScreenUpdate Then
Application.ScreenUpdating = False
End If

Debug.Print bScreenUpdate, Application.ScreenUpdating

' Some code here…

If bScreenUpdate And Application.ScreenUpdating = False Then
Application.ScreenUpdating = True
End If

Debug.Print bScreenUpdate, Application.ScreenUpdating
End Sub

Принцип понятен?