Подскажите, какой должен быть макрос, чтобы: На листе1 - «Закупки», есть сгруппированные таблицы с данными, набираемые вручную. Необходимо, чтобы при открытии любой группировки, была сверху кнопка «ДОБАВИТЬ данные на листы «список1» и «список2»», при нажатии на которую, данные с листа1 переносились бы в перечисленные листы (в «список2» - без колонки «код») А если я открою более одной группировки и попытаюсь нажать на кнопку, то выскакивало бы предупреждение типа: «ЗАКРОЙТЕ ВСЕ ГРУППИРОВКИ, ОСТАВИВ НУЖНУЮ» Спасибо.
День добрый!
Подскажите, какой должен быть макрос, чтобы: На листе1 - «Закупки», есть сгруппированные таблицы с данными, набираемые вручную. Необходимо, чтобы при открытии любой группировки, была сверху кнопка «ДОБАВИТЬ данные на листы «список1» и «список2»», при нажатии на которую, данные с листа1 переносились бы в перечисленные листы (в «список2» - без колонки «код») А если я открою более одной группировки и попытаюсь нажать на кнопку, то выскакивало бы предупреждение типа: «ЗАКРОЙТЕ ВСЕ ГРУППИРОВКИ, ОСТАВИВ НУЖНУЮ» Спасибо.grh1
Sub Macros() Dim adr1 As Long, adr2 As Long, c As Long For i = 9 To ActiveSheet.UsedRange.Item(ActiveSheet.UsedRange.Count).Row If Range("H" & i) = "" And IsNumeric(Range("H" & i + 1)) Then adr1 = i + 1 If Range("H" & i + 1) = "" And IsNumeric(Range("H" & i)) Then adr2 = i If Range(adr1 & ":" & adr2).EntireRow.Hidden = False Then c = c + 1: iadr1 = adr1: iadr2 = adr2 End If Next i If c = 0 Then MsgBox "Нет открытых групп", vbOKOnly + vbCritical, "Ошибка" If c > 1 Then MsgBox "Открыто более одной группы", vbOKOnly + vbCritical, "Ошибка" If c = 1 Then Sheets(2).Range("A2:G1000").Clear Sheets(1).Range("B" & iadr1 & ":H" & iadr2 - 3).Copy (Sheets(2).Range("A2")) Sheets(1).Range("H" & iadr2 - 2 & ":H" & iadr2).Copy (Sheets(2).Range("G" & iadr2 - iadr1)) Sheets(3).Range("A2:F1000").Clear Sheets(1).Range("B" & iadr1 & ":C" & iadr2 - 3).Copy (Sheets(3).Range("A2")) Sheets(1).Range("E" & iadr1 & ":H" & iadr2 - 3).Copy (Sheets(3).Range("C2")) Sheets(1).Range("H" & iadr2 - 2 & ":H" & iadr2).Copy (Sheets(3).Range("F" & iadr2 - iadr1)) MsgBox "Кнопка перенесла данные", vbOKOnly + vbInformation, "УРА!!!" End If End Sub
[/vba] 1 - Начало макроса 2 - Описание переменных 3 - Цикл по ячекам столбца H листа "Закупки" с 9 строки до последней заполненной 4 - Условие если i-ая ячейка пустая и следующая число, то запоминаем номер строки с числом (начало группы) 5 - Условие если i-ая ячейка число и следующая пустая, то 6 - запоминаем номер строки с числом (конец группы) 7 - Условие если группа не скрыта, то в переменной "с" считаем не скрытые группы и запоминаем начало и конец группы для использование дальше. 8 - Конец if 9 - Конец цикла 10, 11 - сообщения об неоткрытии групп и открытии больше одной группы 12 - Условие если открыта одна группа, то 13 - Очистка второго листа 14 - Копируем диапазон из группы кроме итоговых сумм 15 - Копируем итоговые суммы 16 - Очистка третьего листа 17 - Копируем диапазон из столбцов В и С группы 18 - Копируем диапазон из столбцов E и H группы 19 - Копируем итоговые суммы 20 - Сообщение о завершении переноса 21 - Конец if 22 - Конец макроса
[vba]
Код
Sub Macros() Dim adr1 As Long, adr2 As Long, c As Long For i = 9 To ActiveSheet.UsedRange.Item(ActiveSheet.UsedRange.Count).Row If Range("H" & i) = "" And IsNumeric(Range("H" & i + 1)) Then adr1 = i + 1 If Range("H" & i + 1) = "" And IsNumeric(Range("H" & i)) Then adr2 = i If Range(adr1 & ":" & adr2).EntireRow.Hidden = False Then c = c + 1: iadr1 = adr1: iadr2 = adr2 End If Next i If c = 0 Then MsgBox "Нет открытых групп", vbOKOnly + vbCritical, "Ошибка" If c > 1 Then MsgBox "Открыто более одной группы", vbOKOnly + vbCritical, "Ошибка" If c = 1 Then Sheets(2).Range("A2:G1000").Clear Sheets(1).Range("B" & iadr1 & ":H" & iadr2 - 3).Copy (Sheets(2).Range("A2")) Sheets(1).Range("H" & iadr2 - 2 & ":H" & iadr2).Copy (Sheets(2).Range("G" & iadr2 - iadr1)) Sheets(3).Range("A2:F1000").Clear Sheets(1).Range("B" & iadr1 & ":C" & iadr2 - 3).Copy (Sheets(3).Range("A2")) Sheets(1).Range("E" & iadr1 & ":H" & iadr2 - 3).Copy (Sheets(3).Range("C2")) Sheets(1).Range("H" & iadr2 - 2 & ":H" & iadr2).Copy (Sheets(3).Range("F" & iadr2 - iadr1)) MsgBox "Кнопка перенесла данные", vbOKOnly + vbInformation, "УРА!!!" End If End Sub
[/vba] 1 - Начало макроса 2 - Описание переменных 3 - Цикл по ячекам столбца H листа "Закупки" с 9 строки до последней заполненной 4 - Условие если i-ая ячейка пустая и следующая число, то запоминаем номер строки с числом (начало группы) 5 - Условие если i-ая ячейка число и следующая пустая, то 6 - запоминаем номер строки с числом (конец группы) 7 - Условие если группа не скрыта, то в переменной "с" считаем не скрытые группы и запоминаем начало и конец группы для использование дальше. 8 - Конец if 9 - Конец цикла 10, 11 - сообщения об неоткрытии групп и открытии больше одной группы 12 - Условие если открыта одна группа, то 13 - Очистка второго листа 14 - Копируем диапазон из группы кроме итоговых сумм 15 - Копируем итоговые суммы 16 - Очистка третьего листа 17 - Копируем диапазон из столбцов В и С группы 18 - Копируем диапазон из столбцов E и H группы 19 - Копируем итоговые суммы 20 - Сообщение о завершении переноса 21 - Конец if 22 - Конец макросаAlexM
Номер мобильного модема (без голосовой связи) 9269171249 МегаФон, Московский регион.
Уважаемый AlexM, при добавлении новой группировки, выдает ошибку - якобы открыта не одна группировка. Удаляю новую группировку - всё опять работает. Подправьте пожалуйста код, если не спите.
P.S. Вроде разобрался - в шаблоне дело было...
Уважаемый AlexM, при добавлении новой группировки, выдает ошибку - якобы открыта не одна группировка. Удаляю новую группировку - всё опять работает. Подправьте пожалуйста код, если не спите.
P.S. Вроде разобрался - в шаблоне дело было...grh1
Что-то мешало точно определить конец таблицы. Так и не понял что. :-( При удалении на листе "Закупки" 985 строки макрос начинал работать. Возможно, в этой строке где-то есть ячейка, у которой был изменен формат, поэтому определение конца таблицы неточное. Определение последней заполненной строки в начальном коде было [vba]
[/vba] Конец таблицы стал определяться правильно. Из условий убрал лишнее [vba]
Код
And IsNumeric(Range("H" & i + 1))
[/vba] и [vba]
Код
And IsNumeric(Range("H" & i))
[/vba]
Что-то мешало точно определить конец таблицы. Так и не понял что. :-( При удалении на листе "Закупки" 985 строки макрос начинал работать. Возможно, в этой строке где-то есть ячейка, у которой был изменен формат, поэтому определение конца таблицы неточное. Определение последней заполненной строки в начальном коде было [vba]
AlexM, не хочет переносить... Мешает, как и раньше, верхняя пустая строка. Как сделать, чтобы она всё-таки была? Интересно, что открывая старые группировки для переноса - там есть эта строка, но все переносится...!?
Я прикрепил два архива, т.к. уже больше 100 Kb Посмотрите пожалуйста.
AlexM, не хочет переносить... Мешает, как и раньше, верхняя пустая строка. Как сделать, чтобы она всё-таки была? Интересно, что открывая старые группировки для переноса - там есть эта строка, но все переносится...!?
Я прикрепил два архива, т.к. уже больше 100 Kb Посмотрите пожалуйста.grh1
Между групп строк должна быть одна пустая строка. По ней макрос понимает границы групп. Две пустые строки макрос понимает как конец таблицы. Может быть для каждого года делать свой лист закупок, с названием "Закупки 2012" и "Закупки 2013" Если такой вариант вы используете, то в макросе надо отредактировать несколько строк, убрав из них [vba]
Код
Sheets("закупки").
[/vba] или заменить на [vba]
Код
ActiveSheet.
[/vba] Данные при работе макроса будут браться с активного листа, т.е. на котором нажата кнопка.
PS. Я не проверял, но может быть получится. В ячейку H971 таблицы (желтая) вставьте что-нибудь, точку или ноль.
Между групп строк должна быть одна пустая строка. По ней макрос понимает границы групп. Две пустые строки макрос понимает как конец таблицы. Может быть для каждого года делать свой лист закупок, с названием "Закупки 2012" и "Закупки 2013" Если такой вариант вы используете, то в макросе надо отредактировать несколько строк, убрав из них [vba]
Код
Sheets("закупки").
[/vba] или заменить на [vba]
Код
ActiveSheet.
[/vba] Данные при работе макроса будут браться с активного листа, т.е. на котором нажата кнопка.
PS. Я не проверял, но может быть получится. В ячейку H971 таблицы (желтая) вставьте что-нибудь, точку или ноль.AlexM
Номер мобильного модема (без голосовой связи) 9269171249 МегаФон, Московский регион.
Сообщение отредактировал AlexM - Воскресенье, 13.01.2013, 18:22
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
