Страницы: 1
RSS
Разбор листа по книгам по 2-м фильтрам и сохранение
 
Всем добрый день!

Задача здесь встречалась уже 100500 раз, но постоянно всплывают новые вариации, вот и я со своей)

Необходимо с помощью макроса иметь возможность разобрать Лист по Книгам на основании фильтрации по ДВУМ столбцам. По одному столбцу я нашел решение, а вот с двумя гораздо сложнее обстоит дело.

Прикрепляю образец файла, где один лист - оригинал файла, а второй - как должен выглядеть каждый из сохраненных файлов.

Имеем список товаров для заказа по разным магазинам от разных поставщиков. Столбцы для фильтрации: Адрес и Поставщик, т.е. каждый файл должен быть разбит по отдельному поставщику для каждого магазина. И сохранить в эту же папку с именем нового файла сцепка Поставщик_Адрес

И еще, прошу прощения за странный нюанс, но в каждом файле в ячейке А1 должен находиться Код Магазина (он находится в столбце А)

Часть, как говорил, у меня получилось реализовать, но с усложнением уже не справился, поэтому буду очень благодарен любой помощи.
Спасибо!!
 
Эх, никто не хочет вам помогать (
См. файл и комментарии справа от таблицы.

Код
Sub Разбить_на_файлы()
    Dim arrData, Dict As Object, SupplierAddress As String, i As Long, LO As ListObject, origSheet As Worksheet, LOTemp As ListObject
    Dim sSupplier As String, sAddress As String, iKey As Variant, Counter As Long
        
    Set origSheet = Worksheets("Оригинал") '<<--подставьте имя своего листа
    
    Set Dict = CreateObject("Scripting.Dictionary")
    
    With origSheet
        Set LO = .ListObjects(1)
        LO.AutoFilter.ShowAllData
        arrData = LO.Range.Value2
        For i = 2 To UBound(arrData)
            SupplierAddress = Application.Trim(arrData(i, 6) & "|" & arrData(i, 3))
            If Not Dict.exists(SupplierAddress) Then Dict.Item(SupplierAddress) = 0&
        Next i
    End With
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error GoTo errHandler:
    For Each iKey In Dict.keys
        origSheet.Copy
        With ActiveSheet
            Set LOTemp = .ListObjects(1)
            sSupplier = Split(iKey, "|")(0)
            sAddress = Split(iKey, "|")(1)
            LOTemp.Range.AutoFilter Field:=3, Criteria1:="<>" & sAddress
            If LOTemp.ListRows.Count > 1 Then LOTemp.DataBodyRange.Rows.SpecialCells(xlCellTypeVisible).Delete
            LOTemp.AutoFilter.ShowAllData
            If LOTemp.ListRows.Count > 1 Then
                LOTemp.Range.AutoFilter Field:=6, Criteria1:="<>" & sSupplier
                LOTemp.DataBodyRange.Rows.SpecialCells(xlCellTypeVisible).Delete
            End If
            LOTemp.AutoFilter.ShowAllData
            .Rows(1).Insert
            .Range("A1") = Range("A3")
            .Cells.FormatConditions.Delete
            .Columns(6).Delete
        End With
        ActiveWorkbook.SaveAs ThisWorkbook.Path & Application.PathSeparator & sSupplier & "_" & sAddress & ".xlsx", 51  'xlOpenXMLWorkbook
        ActiveWorkbook.Close (False)
        Counter = Counter + 1
    Next iKey

errHandler:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Создано " & Counter & " файлов!", vbExclamation, "Конец"
End Sub
Изменено: New - 01.12.2021 23:55:46
 
Во-первых, спасибо огромное, что откликнулись) все работает на файле примера идеально, на выходе получаем файл - именно то, что надо

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

Спасибо!!
 
Денис, давайте так (чтобы мне не тратить своё время),
сейчас макрос работает так
- ставит фильтр по адресу (не равно нужный адрес)
- удаляет все невошедшие строки
- ставит фильтр по поставщику (не равно нужный поставщик)
- удаляет все невошедшие строки.
- сохраняет файл и переходит к другому адресу и поставщику

Скажите - как макрос должен фильтровать (на какие столбцы какие критерии ставить), чтобы получился нужный результат?
Вы напишите очерёдность для одного файла, а я это реализую в макросе.
- например, ставим фильтр по
- не равно Адрес1 - удаляем невошедшие строки,
- не равно SKU1 - удаляем невошедшие строки,
- не равно Поставщик 1 - удаляем невошедшие строки
сохраняем файл и повторяем для остальных.
Т.е. мне от вас нужна инструкция, чтобы я руками это воспроизвёл, а потом я допишу макрос
Изменено: New - 02.12.2021 14:54:58
 
Цитата
New, написал: Вы напишите очерёдность для одного файла, а я это реализую в макросе.
Понял, пишу)
1. Ставим фильтр на магазин - выбираем один магазин (например, №1)
2. Ставим фильтр на поставщик - выбираем одного поставщика (также №1)
3. Удаляем невошедшее

Следующий шаг:
1. Ставим фильтр на магазин - выбираем один магазин (тот же №1)
2. Ставим фильтр на поставщика - выбираем следующего поставщика (уже №2)
3. Удаляем невошедшее

Таким образом, перебирается один магазин по всем поставщикам. Потом берем магазин №2 и так же перебираем по всем поставщикам отдельно
Для наглядности прикрепляю файл образца, добавил столбец, какая комбинация строк должна попадать в каждый отдельный файл

Спасибо!
 
Цитата
Денис написал:
1. Ставим фильтр на магазин - выбираем один магазин (например, №1)
вы пишите слово "магазин" - я такого столбца не нашёл в вашей таблице.
Вы под словом "магазин" какой столбец таблицы подразумеваете?
Вот, например, столбец А называется "КодМагазина" - вы это имеете ввиду?
Изменено: New - 02.12.2021 16:22:12
 
Цитата
написал:
Вы под словом "магазин" какой столбец таблицы подразумеваете?
Да, согласен, в своих терминах пишу)

Магазин = Адрес, Столбец №3
 
Денис, прости( я не понимаю (
Скачай этот файл и запусти. Будет создано 6 файлов, данные в них совпадают с последним столбцом (Адрес + поставщик). Я сейчас закомментировал удаление столбца с Поставщиком, чтобы глазами было видно в каком файле какой поставщик. Скажи - какой файл неправильный или какой не создался?
В твоём последнем жёлтом столбце - 6 уникальных пар Адрес+Поставщик, так и у меня создаётся 6 файлов
Изменено: New - 02.12.2021 18:20:21
 
У меня тоже 6 книг получается
Код
Sub SENTable2()
Dim Arr1, Dic1, Dic2, Tp1, Tp2, i&, j&, kMax&
Application.ScreenUpdating = False
Set Dic1 = CreateObject("Scripting.Dictionary")
Set Dic2 = CreateObject("Scripting.Dictionary")
Arr1 = Worksheets(1).Cells(1).CurrentRegion: ReDim Tp1(1 To 8)
    For i = 2 To UBound(Arr1)
j = 1: For Each Tp2 In Array(1, 2, 3, 4, 5, 7, 8, 9)
            Tp1(j) = Arr1(i, Tp2): j = j + 1
        Next
        
Tp2 = Dic2(Arr1(i, 3) & "_" & Arr1(i, 6)): j = 1
If Dic1.exists(j & Arr1(i, 3) & "_" & Arr1(i, 6)) Then
For j = 2 To UBound(Arr1)
If Not Dic1.exists(j & Arr1(i, 3) & "_" & Arr1(i, 6)) Then Dic1(j & Arr1(i, 3) & "_" & Arr1(i, 6)) = Tp1: Exit For
Next
Else: Dic1(j & Arr1(i, 3) & "_" & Arr1(i, 6)) = Tp1
End If
If j > kMax Then kMax = j
    Next
For i = 1 To Dic2.Count: Sheets(2).Copy
    For j = 1 To kMax
If Dic1.exists(j & Dic2.keys()(i - 1)) Then Cells(j + 2, 1).Resize(, UBound(Tp1)) = Dic1(j & Dic2.keys()(i - 1))
    Next
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Dic2.keys()(i - 1): ActiveWorkbook.Close
Next
End Sub
 
Цитата
написал:
Скажи - какой файл неправильный или какой не создался?
Это либо мистика, либо что-то еще... Тк в вашем файле примера "Денис_upd.xlsx" - у меня тоже отлично отрабатывает макрос и создает 6 файлов))
А когда переношу в свой (прикрепляю его) - не срабатывает, останавливается на первом поставщике, пишет "Создано 0 файлов" и на этом всё.

Название листа переименовал в Sheet1

Что еще совсем загадочно - это то, что теперь при открытии Excel сами запускаются из буфера 2 созданных правильных файла, с правильными названиями, но они нигде не сохранены. Даже перезагрузка не помогает - все равно выскакивают, где-то висят в памяти, тут вообще непонятно, но это не главная беда)

Прикрепил свой файл, посмотрите, пожалуйста, если у вас отрабатывает, значит у меня что-то глючит в Excel'е  
 
Цитата
Евгений Смирнов написал:
У меня тоже 6 книг получается
Ваша версия макроса на тестовом файле у меня тоже отрабатывает правильно))) Спасибо, что подключились и попробовали

А на рабочем файле выдает ошибку на строке 21:
For i = 1 To Dic2.Count: Sheets(2).Copy
 
Второй лист используется как шаблон для форматирования и создания книг. Поэтому он обязательно должен быть в книге. Лень было писать форматирование. Зато все данные в словаре, поэтому по скорости должно получиться нормально. Оператор копирует Лист с индексом 2 и создается новая книга с этим листом
Код
Sheets(2).Copy
Изменено: Евгений Смирнов - 02.12.2021 19:22:29
 
Денис, создайте, пожалуйста, у вас на компьютере любой файл (текстовый, Excel, Word и т.д.) со звёздочкой (*) в его имени и пришлите принтскрин сюда, я посмотрю на ваш файл. Давайте для примера возьмём название *ПВ Бурдейного.8*.xlsx
Сможете дать файлу такое имя?
Потестируйте этот макрос
Изменено: New - 02.12.2021 19:21:02
 
New У меня Ваш файл нормально отработал
 
Евгений Смирнов, Да, этот файл с макросом и до этого нормально отрабатывал, просто у Дениса в рабочем файле в столбце Адрес все адреса обрамлены с двух сторон звёздочками ( * ). А Windows запрещает создавать файлы, в которых есть звёздочки, знаки вопросов, слеши и тд. А так как мы создаём кучу файлов и в название файла вставляем название поставщика и адрес (который со звёздочками), то макрос рушится. Сейчас добавил в код строку удаления звёздочек в адресе перед сохранением нового файла на диск. И теперь код должен нормально работать с рабочим файлом Дениса... Если только у него не появятся звёздочки в названии поставщика. Вся проблема в том, что в тестовом примере никаких звёздочек в столбце Адрес не было, а в рабочим файле Дениса, который мы не видели они есть.
Изменено: New - 03.12.2021 02:06:50
 
New  Сегодня с утра  разбирался в вашем коде. У Вас алгоритм  проще чем мой. Я долго свой писал.(Учусь пользоваться словарями.)
Вы использовали в качестве критерия автофильтра <> . Мне кажется что лучше было использовать =.
Пожалуйста без обид. Просто моё мнение.
 
да какие обиды))  я использовал <>, чтобы удалить оставшиеся неподходящие под критерий видимые строки. Если использовать =, то нужные строки останутся видимыми, а ненужные скроются - тогда непонятно, как их удалять
Изменено: New - 03.12.2021 06:55:47
 

Не надо удалять. Надо копировать видимые строки

Код
Sub Разбить_на_файлы12()
Dim arrData, Dict As Object, SupplierAddress As String, i As Long, LO As ListObject, origSheet As Worksheet, LOTemp As ListObject
Dim sSupplier As String, sAddress As String, iKey As Variant, Counter As Long, Tp1, Rg1 As Range
    Set origSheet = ActiveSheet 'Worksheets("Оригинал") '<<--подставьте имя своего листа
    Set Dict = CreateObject("Scripting.Dictionary")
        Set LO = origSheet.ListObjects(1)
        LO.AutoFilter.ShowAllData
        arrData = LO.Range.Value2
        For i = 2 To UBound(arrData)
            SupplierAddress = Application.Trim(arrData(i, 6) & "|" & arrData(i, 3))
            If Not Dict.exists(SupplierAddress) Then Tp1 = Dict(SupplierAddress)
        Next i
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error GoTo errHandler:
    
    For Each iKey In Dict.keys
        origSheet.Activate
            sSupplier = Split(iKey, "|")(0)
            sAddress = Split(iKey, "|")(1)
    With LO
    .AutoFilter.ShowAllData
    .Range.AutoFilter Field:=3, Criteria1:=sAddress
    .Range.AutoFilter Field:=6, Criteria1:=sSupplier
Set Rg1 = .Range.SpecialCells(xlCellTypeVisible)
     End With
        Workbooks.Add 1
        Rg1.Copy Cells(2, 1)
        Range("A1") = Range("A3")
        Columns(6).Delete 'удалить столбец с Поставщиком
        sAddress = Replace(sAddress, "*", "")
        ActiveWorkbook.SaveAs ThisWorkbook.Path & Application.PathSeparator & sSupplier & "_" & sAddress & ".xlsx", 51  'xlOpenXMLWorkbook
        ActiveWorkbook.Close (False)
        Counter = Counter + 1
    Next iKey

errHandler:

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    LO.AutoFilter.ShowAllData
    MsgBox "Создано " & Counter & " файлов!", vbInformation, "Конец"
End Sub
Изменено: Евгений Смирнов - 03.12.2021 07:07:12
 
да, согласен. Но тогда теряется умная таблица в файлах, т.е. мы копируем просто диапазон. Я когда писал код хотел оставить умные таблицы в файлах.
Кстати, чтобы не использовать ненужную переменную Tp1 эту строку
Код
If Not Dict.exists(SupplierAddress) Then Tp1 = Dict(SupplierAddress)

можно записать так

Код
If Not Dict.exists(SupplierAddress) Then Dict(SupplierAddress) = 0&
Изменено: New - 03.12.2021 07:13:31
 
New Я проверил у меня ничего не теряется.

А в обоих вариантах словаря значения значения будут пустыми?
 
Умная таблица - это когда ставишь мышкой курсор в любую ячейку таблицы и сверху на ленте появляется вкладка "Конструктор таблиц". Вот в файле с макросом если поставить курсор внутри таблицы, то такая вкладка появляется.
А если мы сделали Rng.Copy в новый файл, то в новом файле - это будет уже не "умная" таблица, а просто раскрашенный диапазон (вкладка "Конструктор таблиц" на ленте не появляется)

Цитата
Евгений Смирнов написал:
А в обоих вариантах словаря значения значения будут пустыми?
словарь у нас один Dict.
мы просто в значение словаря записываем 0 и всё. То есть заполняем только ключи
Изменено: New - 03.12.2021 07:25:04
 
Спасибо Понял разницу.насчет умной таблицы
2 варианта заполнения словаря из сообщения 19. В 1 варианте  значения словаря будут Empty. Во 2 варианте значения текст "0". С точки зрения объема занимаемой памяти какой вариант лучше ?
Изменено: Евгений Смирнов - 03.12.2021 07:31:51
 
но если в файлах не нужна умная таблица (что я решил сделать по своему желанию, ТС не просил так делать), то мне кажется твой вариант оптимальнее
Изменено: New - 03.12.2021 07:26:03
 
New  Если исходных данных много, то по вашему варианту  копирование всего листа видимо будет тормозить, Мой вариант наверно быстрее отработает
Изменено: Евгений Смирнов - 03.12.2021 07:42:39
 
Цитата
New, написал:
Давайте для примера возьмём название *ПВ Бурдейного.8*.xlsxСможете дать файлу такое имя?Потестируйте этот макрос
Добрый день!
Прошу прощения, что пропал - был на семинаре

В общем, действительно, дело было в звездочках - я их удалил и макрос отработал)
Все формирует и сохраняет в самом лучшем виде, только сохраняет в папку с Личной Книгой Макросов PERSONAL.xlsb (прикрепил скрин). Поэтому и выскакивали ранее файлы сформированные, тк это папка автозапуска (прикрепляю скрин). Наверное, тк сохраняю макрос в личную книгу макросов или почему?

Я попытался с ThisWorkbook.Path, но тк нельзя указать постоянный путь сохранения, тк планируется, что макрос будет работать у разных людей, а ActiveWorkbook.Path сюда не подходит, поэтому не получилось разрешить последнюю загвоздку, как сохранять в папку, где изначально находился исходный файл

Спасибо огромное, что возитесь с этим головняком)
Цитата
Евгений Смирнов, поэтому по скорости должно получиться нормально.

Спасибо, что так активно подключились)  
 
Денис, по поводу звёздочек в названии адресов - посмотрите макрос из сообщения №13 или №18, там уже это учтено
Да, сейчас макрос создаёт файлы рядом с файлом в котором записан сам макрос. Если это Личная книга макросов, то там же будут созданы файл.
Если вы знаете другой путь для сохранения файлов, то вместо вот этих слов ThisWorkbook.Path напишите свой путь в кавычках, например, "C:\Temp" (в конце не надо ставить слеш \, он подставится автоматически)
Изменено: New - 03.12.2021 15:47:46
 
Спасибо огромное! Все работает идеально! Очень-очень выручили

Евгений Смирнов, и вам спасибо за вашу версию решения)
Страницы: 1
Наверх