Доброго всем вечера. Суть проблемы в следующем: есть список книг и дел предприятия. Список делиться по отделам. Необходим макрос, который делает следующее: 1) создаёт новый лист "лист 1". Далее копирует с листа "дела" заголовок (ячейки А8:F10) и вставляет его на "лист 1". Дальше с листа "дела" копирует ТОЛЬКО то что относиться к разделу "Учет работников" и так же вставляет на "лист 1". Дальше все также, только копировать необходимо раздел "учет карточек" на "лист 2" и т.д. 2) необходимо проверить столбик А (с нумерацией дел) на поиск недостающих номеров и вывод их, например, в столбик I При помощи "записи макроса" что-то накидал, но до конца так и не получается. Прошу у Вас помощи.
Доброго всем вечера. Суть проблемы в следующем: есть список книг и дел предприятия. Список делиться по отделам. Необходим макрос, который делает следующее: 1) создаёт новый лист "лист 1". Далее копирует с листа "дела" заголовок (ячейки А8:F10) и вставляет его на "лист 1". Дальше с листа "дела" копирует ТОЛЬКО то что относиться к разделу "Учет работников" и так же вставляет на "лист 1". Дальше все также, только копировать необходимо раздел "учет карточек" на "лист 2" и т.д. 2) необходимо проверить столбик А (с нумерацией дел) на поиск недостающих номеров и вывод их, например, в столбик I При помощи "записи макроса" что-то накидал, но до конца так и не получается. Прошу у Вас помощи.sos-13
Sub cpy() Dim rRange As Range, rCell As Range, r&, i& Dim hat As Range Dim all all = Array("Учет работников", "учет личных дел", "учет карточек", "еще учет") Set hat = Sheets(1).[a8:f10] With Application For i = 0 To UBound(all) Set rCell = Sheets(1).Cells.Find(all(i)).Offset(1, 0) r = rCell.Offset(0, 1).End(xlDown).Row - rCell.Row + 1 Set rRange = rCell.Resize(r, 6) Sheets.Add After:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = all(i) hat.Copy Sheets(Sheets.Count).[a1] rRange.Copy Sheets(Sheets.Count).[a4] Next End With End Sub
[/vba]
Высоту строк и столбцов добавьте сами. [moder]Вот это правильное название макроса! Следующий какой будет? _Boroda_[/moder]
[offtop] не так плох макрос, как его название
[vba]
Код
Sub cpy() Dim rRange As Range, rCell As Range, r&, i& Dim hat As Range Dim all all = Array("Учет работников", "учет личных дел", "учет карточек", "еще учет") Set hat = Sheets(1).[a8:f10] With Application For i = 0 To UBound(all) Set rCell = Sheets(1).Cells.Find(all(i)).Offset(1, 0) r = rCell.Offset(0, 1).End(xlDown).Row - rCell.Row + 1 Set rRange = rCell.Resize(r, 6) Sheets.Add After:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = all(i) hat.Copy Sheets(Sheets.Count).[a1] rRange.Copy Sheets(Sheets.Count).[a4] Next End With End Sub
[/vba]
Высоту строк и столбцов добавьте сами. [moder]Вот это правильное название макроса! Следующий какой будет? _Boroda_[/moder]
[offtop] не так плох макрос, как его название SkyPro
skypro1111@gmail.com
Сообщение отредактировал SkyPro - Пятница, 29.11.2013, 20:07
Sub cpy() Dim rRange As Range, rCell As Range, r&, i& Dim hat As Range Dim all all = Array("Учет работников", "учет личных дел", "учет карточек", "еще учет") Set hat = Sheets(1).[a8:f10] With Application For i = 0 To UBound(all) Set rCell = Sheets(1).Cells.Find(all(i)).Offset(1, 0) r = rCell.Offset(0, 1).End(xlDown).Row - rCell.Row + 1 Set rRange = rCell.Resize(r, 6) Sheets.Add After:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = all(i) hat.Copy Sheets(Sheets.Count).[a1] rRange.Copy Sheets(Sheets.Count).[a4] Next End With End Sub
Высоту строк и столбцов добавьте сами.
Спасибо огромное. А по поводу пункта 2) не подскажете?
Sub cpy() Dim rRange As Range, rCell As Range, r&, i& Dim hat As Range Dim all all = Array("Учет работников", "учет личных дел", "учет карточек", "еще учет") Set hat = Sheets(1).[a8:f10] With Application For i = 0 To UBound(all) Set rCell = Sheets(1).Cells.Find(all(i)).Offset(1, 0) r = rCell.Offset(0, 1).End(xlDown).Row - rCell.Row + 1 Set rRange = rCell.Resize(r, 6) Sheets.Add After:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = all(i) hat.Copy Sheets(Sheets.Count).[a1] rRange.Copy Sheets(Sheets.Count).[a4] Next End With End Sub
Высоту строк и столбцов добавьте сами.
Спасибо огромное. А по поводу пункта 2) не подскажете?sos-13
Сейчас пытаюсь найти похожую тему (где-то недавно видел на форуме похожую), но смысл в следующем: первый столбик (начиная с ячейки А4) "№ дела" содержит различные номера не по порядку, начиная с 1. Номеров очень много, более 1500 штук, и чисто машинально пропускаю числа, когда присваиваю новым делам. Вот чтобы не переписывать тупо на листик недостающие номера, хочется, чтобы в столбик выводились недостающие в столбце "№ дела" номера.
Сейчас пытаюсь найти похожую тему (где-то недавно видел на форуме похожую), но смысл в следующем: первый столбик (начиная с ячейки А4) "№ дела" содержит различные номера не по порядку, начиная с 1. Номеров очень много, более 1500 штук, и чисто машинально пропускаю числа, когда присваиваю новым делам. Вот чтобы не переписывать тупо на листик недостающие номера, хочется, чтобы в столбик выводились недостающие в столбце "№ дела" номера.sos-13
Если бы вы еще сказали где найти список всех номеров.. А пока так:[vba]
Код
Sub недостающие_номера() 'Так лучше? Dim x Dim mx& Dim i&, r&, g&: g = 0 Dim arRes&(1 To 100000, 1 To 1) Dim exists As Boolean: exists = False
mx = Application.WorksheetFunction.max([a13:a1500]) x = [a13:a1500]
For i = 0 To mx exists = False For r = 1 To UBound(x) If x(r, 1) = i Then exists = True End If Next If exists = False Then g = g + 1 arRes(g, 1) = i End If Next If g = 0 Then Exit Sub [h1].Resize(g) = arRes End Sub
[/vba]
Если бы вы еще сказали где найти список всех номеров.. А пока так:[vba]
Код
Sub недостающие_номера() 'Так лучше? Dim x Dim mx& Dim i&, r&, g&: g = 0 Dim arRes&(1 To 100000, 1 To 1) Dim exists As Boolean: exists = False
mx = Application.WorksheetFunction.max([a13:a1500]) x = [a13:a1500]
For i = 0 To mx exists = False For r = 1 To UBound(x) If x(r, 1) = i Then exists = True End If Next If exists = False Then g = g + 1 arRes(g, 1) = i End If Next If g = 0 Then Exit Sub [h1].Resize(g) = arRes End Sub
Огромное спасибо!!!!! Все работает. Ну и последний вопрос, извиняюсь за наглость. Такая задача: в столбце "№ дела" несколько раз встречаются дубликаты номеров, например два (или даже три) раза встречаются номера 5, 12, 23 и т.д. Необходимо выделить каждый повторяющийся номер своим цветом, и вывести в одну ячейку (например в ячейку "J2") дубликаты в виде "5-5; 12-12; 23-23"/
Огромное спасибо!!!!! Все работает. Ну и последний вопрос, извиняюсь за наглость. Такая задача: в столбце "№ дела" несколько раз встречаются дубликаты номеров, например два (или даже три) раза встречаются номера 5, 12, 23 и т.д. Необходимо выделить каждый повторяющийся номер своим цветом, и вывести в одну ячейку (например в ячейку "J2") дубликаты в виде "5-5; 12-12; 23-23"/sos-13
Вывел формулами в столбце I минимальный номер, больший самого большого из существующих и 5 минимальных номеров, которых в списке номеров нет. Также сделал условное форматирование - если случайно номера повторяются, то они выделятся красным. И в столбце А сделал выпадающий список с 5-ю первыми на очередь неиспользуемыми до настоящего момента номерами.
Последнего вопроса ТС и совершенно справедливого замечания Лены не видел, однако угадал, похоже. Только не в столбец отдельный вывел, а просто раскрасил условным форматированием
Вывел формулами в столбце I минимальный номер, больший самого большого из существующих и 5 минимальных номеров, которых в списке номеров нет. Также сделал условное форматирование - если случайно номера повторяются, то они выделятся красным. И в столбце А сделал выпадающий список с 5-ю первыми на очередь неиспользуемыми до настоящего момента номерами.
Последнего вопроса ТС и совершенно справедливого замечания Лены не видел, однако угадал, похоже. Только не в столбец отдельный вывел, а просто раскрасил условным форматированием_Boroda_
Опять же извиняюсь за назойливость, но прошу снова помощи. А как сделать так, чтобы данные переносились на вновь созданный лист без форматирования текста, т.е. чтобы как на первом листе (ширина строк, столбцов, размер и тип шрифта и т.д.) так и вставлялось на новый. Спасибо. И ещё один вопросик маленький. Размер файла получается около 130 Мб, это нормально? (количество дел в описи около 1200 штук, количество получаемых листов около 30)
Опять же извиняюсь за назойливость, но прошу снова помощи. А как сделать так, чтобы данные переносились на вновь созданный лист без форматирования текста, т.е. чтобы как на первом листе (ширина строк, столбцов, размер и тип шрифта и т.д.) так и вставлялось на новый. Спасибо. И ещё один вопросик маленький. Размер файла получается около 130 Мб, это нормально? (количество дел в описи около 1200 штук, количество получаемых листов около 30)sos-13
Сообщение отредактировал sos-13 - Суббота, 30.11.2013, 12:41
Опять же извиняюсь за назойливость, но прошу снова помощи. А как сделать так, чтобы данные переносились на вновь созданный лист без форматирования текста, т.е. чтобы как на первом листе (ширина строк, столбцов, размер и тип шрифта и т.д.) так и вставлялось на новый. Спасибо.
Эту проблему решил. Но все равно огромное спасибо всем за помощь. А вот по размеру файла не подскажете?
Опять же извиняюсь за назойливость, но прошу снова помощи. А как сделать так, чтобы данные переносились на вновь созданный лист без форматирования текста, т.е. чтобы как на первом листе (ширина строк, столбцов, размер и тип шрифта и т.д.) так и вставлялось на новый. Спасибо.
Эту проблему решил. Но все равно огромное спасибо всем за помощь. А вот по размеру файла не подскажете?sos-13