Добрый день! Нужна помощь в следующем вопросе. Есть прайс поставщика (примерно 10 тыс. строк) с кучей издательств и информации по товару. Нужно автоматизировать, насколько возможно, процесс вычленения конкретного издательства с копированием этого товара в отдельную книгу/лист. В прикрепленном файле условный прайс. В нем нужно вытащить издательство Спейс, к примеру, с сохранением структуры прайса, т.е., чтобы остались разделы. Фильтр пробовал, он тут не особо помогает. Вкратце, суть в том, чтобы из всего списка перенести на отдельный лист товар конкретного издателя. Заранее очень сильно благодарен за помощь!
Добрый день! Нужна помощь в следующем вопросе. Есть прайс поставщика (примерно 10 тыс. строк) с кучей издательств и информации по товару. Нужно автоматизировать, насколько возможно, процесс вычленения конкретного издательства с копированием этого товара в отдельную книгу/лист. В прикрепленном файле условный прайс. В нем нужно вытащить издательство Спейс, к примеру, с сохранением структуры прайса, т.е., чтобы остались разделы. Фильтр пробовал, он тут не особо помогает. Вкратце, суть в том, чтобы из всего списка перенести на отдельный лист товар конкретного издателя. Заранее очень сильно благодарен за помощь!Vinney
Спасибо большое за помощь, но тут не совсем все просто. Проблема в том, что при фильтрации не сохраняется структура прайса. Т.е., допустим, есть раздел Альбомы для рисования и в нем есть товар разных производителей. Нужно, чтобы сам раздел остался, но в нем остался только товар конкретного проиводителя. Если это вообще реально воплотить, в чем лично я уже начинаю сомневаться))
Спасибо большое за помощь, но тут не совсем все просто. Проблема в том, что при фильтрации не сохраняется структура прайса. Т.е., допустим, есть раздел Альбомы для рисования и в нем есть товар разных производителей. Нужно, чтобы сам раздел остался, но в нем остался только товар конкретного проиводителя. Если это вообще реально воплотить, в чем лично я уже начинаю сомневаться))Vinney
Сообщение отредактировал Vinney - Понедельник, 07.12.2015, 13:20
Sub d() Dim s$, r As Range, Fr As Range, Fullr As Range s = InputBox("Критерий", , "Спейс") Sheets(1).Copy After:=Sheets(1) With Sheets(2).UsedRange For Each r In .Rows On Error Resume Next If Len(r.Cells(1, 1)) = 6 Then ' If r.OutlineLevel = 5 Then Set Fr = Nothing: Set Fr = r.Find(What:=s, After:=r.Cells(1, 1), LookIn:=xlFormulas, _ LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Fr Is Nothing Then If Fullr Is Nothing Then Set Fullr = r Else Set Fullr = Union(r, Fullr) End If Next End With Fullr.Delete Shift:=xlUp End Sub
Sub d() Dim s$, r As Range, Fr As Range, Fullr As Range s = InputBox("Критерий", , "Спейс") Sheets(1).Copy After:=Sheets(1) With Sheets(2).UsedRange For Each r In .Rows On Error Resume Next If Len(r.Cells(1, 1)) = 6 Then ' If r.OutlineLevel = 5 Then Set Fr = Nothing: Set Fr = r.Find(What:=s, After:=r.Cells(1, 1), LookIn:=xlFormulas, _ LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Fr Is Nothing Then If Fullr Is Nothing Then Set Fullr = r Else Set Fullr = Union(r, Fullr) End If Next End With Fullr.Delete Shift:=xlUp End Sub
А можно еще вопрос? После обработки прайса остается много названий разделов, где не было продукции искомого производителя, но сами разделы не удалены, естесственно. В прикрепленном файле пример того, что остается после обработки. Каким образом можно удалить эти пустые разделы?
А можно еще вопрос? После обработки прайса остается много названий разделов, где не было продукции искомого производителя, но сами разделы не удалены, естесственно. В прикрепленном файле пример того, что остается после обработки. Каким образом можно удалить эти пустые разделы?Vinney
Sub d() Dim s$, r As Range, Fr As Range, Fullr As Range, i&, m%, mas(1 To 4) As Boolean, ii%, b As Boolean s = InputBox("Критерий", , "Спейс") 's = "Спейс" Sheets(1).Copy After:=Sheets(1) With Sheets(2).UsedRange i = .Rows.Count m = 4 Do On Error Resume Next Set r = .Rows(i) If Len(r.Cells(1, 1)) = 6 Then m = 5 Set Fr = Nothing: Set Fr = r.Find(What:=s, After:=r.Cells(1, 1), LookIn:=xlFormulas, _ LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Fr Is Nothing Then If Fullr Is Nothing Then Set Fullr = r Else Set Fullr = Union(r, Fullr) Else For ii = 1 To 4: mas(ii) = 1: Next End If Else If Not mas(r.OutlineLevel) Then If Fullr Is Nothing Then Set Fullr = r Else Set Fullr = Union(r, Fullr) mas(r.OutlineLevel) = 0 End If i = i - 1 Loop While i >= 3 Fullr.Delete Shift:=xlUp End With End Sub
[/vba]
Пробуйте: [vba]
Код
Sub d() Dim s$, r As Range, Fr As Range, Fullr As Range, i&, m%, mas(1 To 4) As Boolean, ii%, b As Boolean s = InputBox("Критерий", , "Спейс") 's = "Спейс" Sheets(1).Copy After:=Sheets(1) With Sheets(2).UsedRange i = .Rows.Count m = 4 Do On Error Resume Next Set r = .Rows(i) If Len(r.Cells(1, 1)) = 6 Then m = 5 Set Fr = Nothing: Set Fr = r.Find(What:=s, After:=r.Cells(1, 1), LookIn:=xlFormulas, _ LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If Fr Is Nothing Then If Fullr Is Nothing Then Set Fullr = r Else Set Fullr = Union(r, Fullr) Else For ii = 1 To 4: mas(ii) = 1: Next End If Else If Not mas(r.OutlineLevel) Then If Fullr Is Nothing Then Set Fullr = r Else Set Fullr = Union(r, Fullr) mas(r.OutlineLevel) = 0 End If i = i - 1 Loop While i >= 3 Fullr.Delete Shift:=xlUp End With End Sub
Допиливаю макрос до победного конца. Возник вопрос - мне нужно "подравнять" высоту строк, но метод AutoFit почему то не работает Макрос выглядит таким образом [vba]
[/vba] i - это координата конца списка. Выделение происходит, но выравнивание по высоте нет. Подскажите, что тут не так? [moder]Код нужно оформлять тегами (кнопка #). Поправила за Вас[/moder]
Допиливаю макрос до победного конца. Возник вопрос - мне нужно "подравнять" высоту строк, но метод AutoFit почему то не работает Макрос выглядит таким образом [vba]
[/vba] i - это координата конца списка. Выделение происходит, но выравнивание по высоте нет. Подскажите, что тут не так? [moder]Код нужно оформлять тегами (кнопка #). Поправила за Вас[/moder]Vinney
Сообщение отредактировал Manyasha - Среда, 09.12.2015, 10:01
Спасибо, заработало! Еще вопросик. Нужно скопировать формулу из ячейки и протянуть от начала (ячейка "Цена", она же именованный диапазон "цена") до конца таблицы (координата конца таблицы известна)
Спасибо, заработало! Еще вопросик. Нужно скопировать формулу из ячейки и протянуть от начала (ячейка "Цена", она же именованный диапазон "цена") до конца таблицы (координата конца таблицы известна)Vinney
Подскажите, пожалуйста. Нужно скопировать часть таблицы в другой лист. Не могу задать область копирования, т.к. в процессе выполнения макрос удаляет ненужные столбцы и я не могу знать координаты конца таблицы вправо. Допустим, мне нужен фрагмент, заканчивающийся колонкой "Мин. уп". Во вложении пример, область копирования выделена красным цветом
[moder]Новый вопрос - новая тема. Читаем Правила форума[/moder]
Подскажите, пожалуйста. Нужно скопировать часть таблицы в другой лист. Не могу задать область копирования, т.к. в процессе выполнения макрос удаляет ненужные столбцы и я не могу знать координаты конца таблицы вправо. Допустим, мне нужен фрагмент, заканчивающийся колонкой "Мин. уп". Во вложении пример, область копирования выделена красным цветом
[moder]Новый вопрос - новая тема. Читаем Правила форума[/moder]Vinney
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
. Пробуйте так:
