добавление и удаление строк одновремменно на разных листах - Microsoft Office Excel

VITA11111 · 13.05.2013, 21:43

надо удалить или добавить строки на разных листах
на одном листе добаляются строки и автоматически добавляются на другом

Код:

 Sub ДОБАВИТЬ_СТРОКИ()
    Dim x As Range, y As Range: Application.ScreenUpdating = False
    Set x = Range(Cells(Sheets("KN").[G7] - 1, 1), Cells(Sheets("KN").[G7] - 1, 30))
    x.Copy
    x.Insert Shift:=xlDown
    Application.CutCopyMode = False
    With Sheets("РАБОЧИЙ ПЛАН")
    Set y = .Range(.Cells(Sheets("KN").[D7] - 1, 1), .Cells(Sheets("KN").[D7] - 1, 1534))
    y.Copy
    y.Insert Shift:=xlDown
    End With
End Sub

Код:

 Sub УДАЛИТЬ_СТРОКИ()
    Dim x As Range: Application.ScreenUpdating = False
    Set x = Range(Cells(Sheets("KN").[G7], 1), Cells(Sheets("KN").[G7], 30))
    x.Delete Shift:=xlUp
End Sub

VITA11111 · 13.05.2013, 21:49

?????????????

kalbasiatka · 14.05.2013, 00:32

Код есть. В чём проблема?

VITA11111 · 14.05.2013, 01:36

Sheets("kn").[D7]- это последняя строка в подразделе общей таблицы,где все таблицы соеденяютсяна листе "РАБОЧИЙ ПЛАН"
Sheets("kn").[G7]-это последняя строка в подразделе отдельной части таблицы на листе" техническая подготовка" является активным листом
на листе "kn" таблица расчетами последних и первых строк в подразделах и в общей таблице

Код:

Sub ДОБАВИТЬ_СТРОКИ()
    Dim x As Range, y As Range: Application.ScreenUpdating = False
    Set x = Range(Cells(Sheets("kn").[G7] - 1, 1), Cells(Sheets("kn").[G7] - 1, 30))
    x.Copy
    x.Insert Shift:=xlDown
    Application.CutCopyMode = False
    With Sheets("РАБОЧИЙ ПЛАН")
    Application.ScreenUpdating = False
    Set y = .Range(.Cells(Sheets("kn").[D7] - 1, 1), .Cells(Sheets("kn").[D7] - 1, 1534))
    y.Copy
    y.Insert Shift:=xlDown
    Application.CutCopyMode = False
    End With
    Sheets("РАБОЧИЙ ПЛАН").Rows(Sheets("kn").[D135]).RowHeight = 35
    Sheets("РАБОЧИЙ ПЛАН").Rows(Sheets("kn").[D135] + 1).RowHeight = 35
    Sheets("РАБОЧИЙ ПЛАН").Rows(Sheets("kn").[D135] + 2).RowHeight = 400
    Sheets("РАБОЧИЙ ПЛАН").Run.Application "ПОКАЗАТЬ_СТРОКИ"
    Sheets("РАБОЧИЙ ПЛАН").Run.Application "СКРЫТЬ_СТРОКИ"
End Sub
Sub УДАЛИТЬ_СТРОКИ()
    Dim x As Range: Application.ScreenUpdating = False
    Set x = Range(Cells(Sheets("KN").[G7], 1), Cells(Sheets("KN").[G7], 30))
    x.Delete Shift:=xlUp
End Sub

проверте пожалуйста написание кода
действует долго около 15 секунд
может кто знает как его ускорить

SAS888 · 14.05.2013, 05:38

1. Вы вставляете 1534 ячейки. Осмелюсь предположить, что в них есть формулы. Попробуйте на время выполнения макроса отключить автопересчет формул:

Код:

Application.Calculation = xlManual
'
'код макроса
'
Application.Calculation = xlAutomatic

2. Неизвестно, что делают, и сколько времени работают макросы "ПОКАЗАТЬ_СТРОКИ" и "СКРЫТЬ_СТРОКИ". Правильно записывать так:

Код:

Application.Run "ПОКАЗАТЬ_СТРОКИ"

VITA11111 · 14.05.2013, 10:21

Код:

Sub qq()
    Dim y As Range: Application.Calculation = xlManual: Application.ScreenUpdating = False
        Set y = Range(Cells(Sheets("kn").[D7] - 1, 1), Cells(Sheets("kn").[D7] - 1, 1534))
            y.Copy
            y.Insert Shift:=xlDown
            Application.CutCopyMode = False
        Application.Calculation = xlAutomatic
End Sub

срабатывает аж 40 секунд
,а всевото нужно вставить строку с формулами

SAS888 · 14.05.2013, 11:23

Цитата:

...а всевото нужно вставить строку с формулами

Как раз в этом и проблема. Хотите быстрее - откажитесь от формул, поручив все вычисления макросам.

VITA11111 · 15.05.2013, 13:43

можно както эти ти макроса соеденить в одном????????

Код:

Sub ДОБАВИТЬ_СТРОКИ()
    Dim x As Range: Application.Calculation = xlManual: Application.ScreenUpdating = False
        Set x = Range(Cells(Sheets("kn").[G7] - 1, 1), Cells(Sheets("kn").[G7] - 1, 30))
            x.Copy
            x.Insert Shift:=xlDown
            Application.CutCopyMode = False
            Cells(Sheets("kn").[G7], 3).Select
            Selection.ClearContents
        Application.Calculation = xlAutomatic
        Run "лист16.макрос1"
End Sub
Sub макрос1()
    With Sheets("РАБОЧИЙ ПЛАН")
    Dim y As Range: Application.Calculation = xlManual: Application.ScreenUpdating = False
        Set y = Range(Cells(Sheets("kn").[D7], 1), Cells(Sheets("kn").[D7], 1534))
            y.Copy
            y.Insert Shift:=xlDown
            Application.CutCopyMode = False
            Application.Calculation = xlAutomatic
    End With
            Run "лист16.ПОКАЗАТЬ_СТРОКИ"
            Run "лист68.макрос2"
            Rows(Sheets("kn").[D135]).RowHeight = 35
            Rows(Sheets("kn").[D135] + 1).RowHeight = 35
            Rows(Sheets("kn").[D135] + 2).RowHeight = 400
            Application.ScreenUpdating = True
            Run "лист68.макрос2"
End Sub
Sub макрос2()
    With Sheets("2")
    Dim x As Range: Application.Calculation = xlManual: Application.ScreenUpdating = False
        Set x = Range(Cells(Sheets("kn").[K7] - 2, 1), Cells(Sheets("kn").[L7] - 2, 137))
            x.Copy
            x.Insert Shift:=xlDown
            Application.CutCopyMode = False
            Cells(Sheets("kn").[K7], 5).Select
            Selection.ClearContents
        Application.Calculation = xlAutomatic
    End With
End Sub

VITA11111 · 15.05.2013, 14:23

ВЫПОЛНЯЕТСЯ ТОЛЬКО НА ЛИСТЕ"ТЕХНИКА НАПАДЕНИЯ"?????

Код:

Sub dobavit_stroki()
   Dim x As Range, y As Range, z As Range: Application.ScreenUpdating = False: Application.Calculation = xlManual                        
       With Sheets("ТЕХНИКА НАПАДЕНИЯ")
           Set x = Range(Cells(Sheets("kn").[G7] - 1, 1), Cells(Sheets("kn").[G7] - 1, 30))
           x.Copy
           x.Insert Shift:=xlDown
             Application.CutCopyMode = False
             Cells(Sheets("kn").[G7], 3).Select
             Selection.ClearContents
       End With
                   With Sheets("РАБОЧИЙ ПЛАН")
                       Set y = Range(Cells(Sheets("kn").[D7] - 1, 1), Cells(Sheets("kn").[D7] - 1, 1534))
                       y.Copy
                       y.Insert Shift:=xlDown
                         Application.CutCopyMode = False
                         Cells(Sheets("kn").[D7], 3).Select
                         Selection.ClearContents
                         Run "лист16.ПОКАЗАТЬ_СТРОКИ"
                         Rows(Sheets("kn").[D135]).RowHeight = 35
                         Rows(Sheets("kn").[D135] + 1).RowHeight = 35
                         Rows(Sheets("kn").[D135] + 2).RowHeight = 400
                   End With
                               With Sheets("2")
                                   Set z = Range(Cells(Sheets("kn").[K7] - 2, 1), Cells(Sheets("kn").[L7] - 2, 137))
                                   z.Copy
                                   z.Insert Shift:=xlDown
                                     Application.CutCopyMode = False
                                     Cells(Sheets("kn").[K7], 5).Select
                                     Selection.ClearContents
                               End With
       Application.Calculation = xlAutomatic
End Sub

SAS888 · 16.05.2013, 07:40

Потому, что Вы не используете метод With...End With.
Почитайте справку. Посмотрите пример кода ниже (если, конечно, я все правильно понял). Обратите внимание на точки вместо ссылок в конструкции With:

Код:

Sub dobavit_stroki()
    Dim x As Range, ws As Worksheet
    Application.ScreenUpdating = False: Application.Calculation = xlManual
    Set ws = Sheets("kn")
    With Sheets("ТЕХНИКА НАПАДЕНИЯ")
        Set x = .Range(.Cells(ws.[G7] - 1, 1), .Cells(ws.[G7] - 1, 30))
        x.Copy: x.Insert Shift:=xlDown
        .Cells(ws.[G7], 3).ClearContents
    End With
    With Sheets("РАБОЧИЙ ПЛАН")
        Set x = .Range(.Cells(ws.[D7] - 1, 1), .Cells(ws.[D7] - 1, 1534))
        x.Copy: x.Insert Shift:=xlDown
        .Cells(ws.[D7], 3).ClearContents
        Run "лист16.ПОКАЗАТЬ_СТРОКИ"
        .Rows(ws.[D135]).RowHeight = 35
        .Rows(ws.[D135] + 1).RowHeight = 35
        .Rows(ws.[D135] + 2).RowHeight = 400
        End With
    With Sheets("2")
        Set x = .Range(.Cells(ws.[K7] - 2, 1), .Cells(ws.[L7] - 2, 137))
        x.Copy: x.Insert Shift:=xlDown
        .Cells(ws.[K7], 5).ClearContents
    End With
    Application.ScreenUpdating = True: Application.Calculation = xlAutomatic
End Sub

14.05.2013, 00:32	#3
kalbasiatka Форумчанин Регистрация: 21.10.2012 Сообщений: 208	Код есть. В чём проблема? krasavec-man@mail.ru Последний раз редактировалось kalbasiatka; 14.05.2013 в 00:35.

14.05.2013, 05:38	#5
SAS888 Старожил Регистрация: 05.12.2007 Сообщений: 4,180	1. Вы вставляете 1534 ячейки. Осмелюсь предположить, что в них есть формулы. Попробуйте на время выполнения макроса отключить автопересчет формул: Код: `Application.Calculation = xlManual ' 'код макроса ' Application.Calculation = xlAutomatic` 2. Неизвестно, что делают, и сколько времени работают макросы "ПОКАЗАТЬ_СТРОКИ" и "СКРЫТЬ_СТРОКИ". Правильно записывать так: Код: `Application.Run "ПОКАЗАТЬ_СТРОКИ"` Чем шире угол зрения, тем он тупее. Последний раз редактировалось SAS888; 14.05.2013 в 08:44.

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Как связать значения на разных листах при добавлении строк?	onitro	Microsoft Office Excel	4	25.01.2013 14:54
Добавление новых строк на 2 листах по условиям	Uralmaster	Microsoft Office Excel	8	27.02.2011 07:16
Выборка строк с одинаковыми значениями на разных листах	bernanke	Microsoft Office Excel	3	26.01.2011 23:29
Объединение данных из разных Файлов на разных листах одной книги	Nikodim113	Microsoft Office Excel	20	12.01.2011 07:12
Поиск и удаление совпадающих строк в разных листах	hybrid84	Microsoft Office Excel	11	24.07.2009 05:13

13.05.2013, 21:49	#2
VITA11111 Пользователь Регистрация: 03.07.2012 Сообщений: 50	?????????????