Скрыть работу скрипта - Компьютерный форум OSzone.net

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)

- Microsoft Office (Word, Excel, Outlook и т.д.) (http://forum.oszone.net/forumdisplay.php?f=115)

- - Скрыть работу скрипта (http://forum.oszone.net/showthread.php?t=314253)

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

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

Код:

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

Цитата:

Цитата blackeangel

не предлагать - не работают. »

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

Цитата:

Цитата Iska (Сообщение 2629638)

Цитата:

Цитата blackeangel

не предлагать - не работают. »

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

Так скажите как будет к месту?
Если оставить только в All in one () то результат тот же, прыгают и скачут листы.

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

Цитата:

Цитата Iska (Сообщение 2629873)

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

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

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

Цитата:

Цитата blackeangel

Если оставить только в All in one () то результат тот же, прыгают и скачут листы. »

проблему. При этом код, как минимум, не будет содержать ошибок времени исполнения.

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

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

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

Цитата:

Цитата Iska (Сообщение 2629951)

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

Хорошо. Можно этот код как то переписать избегая перехода на листы?
Просто некоторые Sub используются отдельно в надстройке как самостоятельные и из них выкинуть Application.ScreenUpdating никак.

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

Цитата:

Цитата blackeangel

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

например так:

Код:

    Dim DefaultActiveSheet As Worksheet

    Set DefaultActiveSheet = ActiveWorkbook.ActiveSheet

    ActiveWorkbook.Sheets.Add

    DefaultActiveSheet.Activate

    Set DefaultActiveSheet = Nothing

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

Как-то так:

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

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

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

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

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

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

Цитата:

Цитата blackeangel

А создать сразу неактивный никак? »

Поиск ничего не дал, мне способ не известен.

Цитата:

Цитата blackeangel

Просто все равно если нет скринапдатера то все это видно будет. »

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

Цитата:

Цитата a_axe (Сообщение 2630183)

Цитата:

Цитата blackeangel

А создать сразу неактивный никак? »

Поиск ничего не дал, мне способ не известен.

Цитата:

Цитата blackeangel

Просто все равно если нет скринапдатера то все это видно будет. »

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

Цитата:

Цитата blackeangel

Просто некоторые Sub используются отдельно в надстройке как самостоятельные и из них выкинуть Application.ScreenUpdating никак. »

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

Цитата:

Цитата Iska (Сообщение 2630217)

Цитата:

Цитата blackeangel

Это как?

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

Скрытый текст

Код:

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

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