Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1 2 След.
RSS
Разделить прайс на разные листы
 
Добрый день!

Есть прайс, требуется разделить его на разные листы, но по категориям которые указаны в столбце B. Желательно, чтобы листы назывались как и категории в столбце B. Как это можно реализовать? Спасибо.
Изменено: Deaviarat - 5 Сен 2018 11:03:06
 
Цитата
Deaviarat написал:
Как это можно реализовать
Вариантов несколько можно ручками поковырять, можно с помощью VBA, с PQ не знаком, но думаю что можно и с помощью этой надстройки (хотя не факт).
Первые 2 варианта однозначно рабочие, т.е. выполнимые. А по ссылке это вы можете смотреть свои файлы, но у меня, например, доступ к таким ресурсам закрыт.
Поэтому потрудитесь сделать небольшой файл пример и прикрепить к сообщению, вероятнее всего в этом случае, и помощь придет намного быстрей.
Изменено: Nordheim - 5 Сен 2018 10:23:45
"Все гениальное просто, а все простое гениально!!!"
 
Не только можно. Но уже столько раз реализовалось, что аж скучно писать снова. Я обычно делаю это AdvancedFilter'ом. Копирую лист, фильтрую в новое место, удаляю исходные данные.
Изменено: StoTisteg - 5 Сен 2018 10:30:45
 
Nordheim, прикрепил файл
 
StoTisteg, Если не затруднит можете на примере показать. Спасибо
 
так?
1. делаете сводную
2. Анализ -> блок "Сводная таблица" -> Отобразить страницы фильтра отчета
PS. точки на запятые в исходных данных поменяйте
Изменено: Stics - 5 Сен 2018 11:03:41
 
Stics, почти. только как убрать, то что красным выделил. И в столбце А должно быть название которое указано в исходнике в столбце B
Screenshot_1.jpg (52.15 КБ)
Изменено: Deaviarat - 5 Сен 2018 11:13:58
 
Это поле фильтра сводной таблицы. Если его удалить, то фильтр отключится.
Выделите все нужные листы -> Выделите строки, которые хотите скрыть -> ПКМ на выделенных строках -> Скрыть

Цитата
Deaviarat написал:
И в столбце А должно быть название которое указано в исходнике в столбце B
это уж сами исправляйте в сводной как вам удобнее

Цитата
StoTisteg написал:
Я обычно делаю это AdvancedFilter'ом.
Про варинант с расширенным фильтром посмотрите в Приёмах
Изменено: Stics - 5 Сен 2018 11:24:46
 
Цитата
Deaviarat написал:
Если не затруднит можете на примере показать.
Прямо, в лоб и без оптимизации:
Код
Sub DivEtImp()
 
   Dim Cats As Collection
   Dim i As Long, cl As Long, rw As Long
   Dim Cat As Variant
   Dim ShNam As String
    
   Application.ScreenUpdating = False
   With Worksheets(1)
      cl = .Cells(1, Columns.Count).End(xlToLeft).Column
      rw = .Cells(Rows.Count, 2).End(xlUp).Row
      Worksheets.Add after:=Worksheets(Sheets.Count)
      .Columns(2).Copy Destination:=Columns(1)
   End With
   Cells.RemoveDuplicates Columns:=1, Header:=xlYes
   Set Cats = New Collection
   For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
      Cats.Add Cells(i, 1).Value
   Next i
   Application.DisplayAlerts = False
   Worksheets(Sheets.Count).Delete
   For Each Cat In Cats
      Worksheets(1).Copy after:=Worksheets(Sheets.Count)
      ShNam = IIf(Len(Cat) > 31, Left(Cat), Cat)
      ActiveSheet.Name = ShNam
      Cells(1, 2).Copy Destination:=Cells(1, cl + 2)
      Cells(2, cl + 2).Value = Cat
      Range(Cells(1, 1), Cells(rw, cl)).AdvancedFilter Action:=xlFilterCopy, criteriarange:=Range(Cells(1, cl + 2), Cells(2, cl + 2)), copytorange:=Cells(1, cl + 4)
      Range(Columns(1), Columns(cl + 3)).Delete
      Columns(2).Delete
      Range(Columns(1), Columns(cl - 1)).EntireColumn.AutoFit
   Next Cat
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
 
End Sub
Изменено: StoTisteg - 5 Сен 2018 14:42:04
 
Как вариант.

Код
Option Explicit

Sub test()
'    ---------------------------------------
    Dim iConnection As ADODB.Connection
    Dim iRecordset As ADODB.Recordset
    Dim book As Workbook, sht As Worksheet
    Dim coll As Collection, iPath$, i&, arr()
    Dim isht As Worksheet, ikey, cnct$, iSelect$
    Dim iColumnName$
'    ---------------------------------------
    Set coll = New Collection
    Set iConnection = New ADODB.Connection
    Set iRecordset = New ADODB.Recordset
    Set book = ThisWorkbook
    Set sht = book.Worksheets("Лист1")
    iPath = ThisWorkbook.Path & Application.PathSeparator & book.Name
    cnct = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & iPath & ";Extended Properties='Excel 12.0;HDR=YES';"
    iConnection.ConnectionString = cnct
    iColumnName = sht.[b1].Value
    On Error Resume Next
        For i = 2 To sht.Range("b" & sht.Rows.Count).End(xlUp).Row
            With sht
                coll.Add .Range("b" & i).Value, .Range("b" & i).Value
            End With
        Next i
    On Error GoTo 0
    Application.ScreenUpdating = False
    For Each ikey In coll
        iConnection.Open
        iSelect = "SELECT * FROM [" & sht.Name & "$] WHERE [" & iColumnName & "]= '" & ikey & "'"
        iRecordset.Open iSelect, iConnection
        Set isht = Worksheets.Add(after:=sht)
        With isht
            .Name = Left(ikey, 30)
            sht.Rows(1).Copy .Rows(1)
           .Range("a2").CopyFromRecordset iRecordset
           .Columns.AutoFit
        End With
        iConnection.Close
    Next ikey
    Application.ScreenUpdating = True
    MsgBox "Готово!"
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
Поставьте Plex:Диапазоны-Разобрать-2-й столбец...
 
Или так:
Код
Sub DivEtImp()

   Dim Cats As Collection
   Dim i As Long, cl As Long, rw As Long
   Dim Dic As Object
   Dim ShNam As String
   
   Application.ScreenUpdating = False
   Set Dic = CreateObject("Scripting.Dictionary")
   With Worksheets(1)
      cl = .Cells(1, Columns.Count).End(xlToLeft).Column
      rw = .Cells(Rows.Count, 2).End(xlUp).Row
      For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
         On Error Resume Next
         Dic.Add Key:=.Cells(i, 2).Value, Item:=""
      Next i
   End With
   Application.ScreenUpdating = False
   With Dic
      For i = 0 To .Count - 1
         Worksheets(1).Copy after:=Worksheets(Sheets.Count)
         ShNam = IIf(Len(.Keys()(i)) > 31, Left(.Keys()(i), 31), .Keys()(i))
         ActiveSheet.Name = ShNam
         Cells(1, 2).Copy Destination:=Cells(1, cl + 2)
         Cells(2, cl + 2).Value = .Keys()(i)
         Range(Cells(1, 1), Cells(rw, cl)).AdvancedFilter Action:=xlFilterCopy, criteriarange:=Range(Cells(1, cl + 2), Cells(2, cl + 2)), copytorange:=Cells(1, cl + 4)
         Range(Columns(1), Columns(cl + 3)).Delete
         Columns(2).Delete
         Range(Columns(1), Columns(cl - 1)).EntireColumn.AutoFit
      Next i
   End With
   Application.ScreenUpdating = True

End Sub
Изменено: StoTisteg - 5 Сен 2018 14:38:09
 
Цитата
StoTisteg написал:
Или так:
Я бы по ключам словаря прошелся циклом For Each ...Next, так вроде быстрей да и код более удобочитаемый :D
"Все гениальное просто, а все простое гениально!!!"
 
Уважаемый Nordheim!
Предупреждаю: я - не профессионал.   :)
Я попробовала запустить Ваш макрос - test().
До выполнения дело не дошло:
Код
Dim iConnection As ADODB.Connection
И см. картинку
Помогите, пожалуйста.
VBA.JPG (13.79 КБ)
 
Nordheim, дело вкуса... Код в принципе не совсем допиленный, например, Dim Cats As Collection там от старого варианта осталось. А так я в первом варианте предпочитаю циклы со счётчиком юзать, а ну как индекс внутри цикла ВНЕЗАПНО понадобится.
 
Мотя, это у Вас в Tools—References какая-то библиотека не подключена...
 
Цитата
Мотя написал:
Помогите, пожалуйста.
Вариант 1:

Код
 'это
    Dim iConnection As ADODB.Connection
    Dim iRecordset As ADODB.Recordset
    'заменить на
    Dim iConnection As Object
    Dim iRecordset As Object
    'и
    ' это
    Set iConnection = New ADODB.Connection
    Set iRecordset = New ADODB.Connection
    'заменить на
    Set iConnection = CreateObject("ADODB.Connection")
    Set iRecordset = CreateObject("ADODB.Recordset")
"Все гениальное просто, а все простое гениально!!!"
 
В
Цитата
Мотя написал:
И см. картинкуПомогите, пожалуйста.
Вариант 2: Нужно подключить библиотеку в
Цитата
StoTisteg написал:
Tools—References
"Все гениальное просто, а все простое гениально!!!"
 
Цитата
StoTisteg написал:
а ну как индекс внутри цикла
Можно переменную счетчик вписать в цикл, просо где то слышал при больших объемах цикл For Each ... Next предпочтительней цикла For ... Next. Вссе дело в скорости.
"Все гениальное просто, а все простое гениально!!!"
 
Всем большое спасибо за помощь!
 
Nordheim!
Цитата
Nordheim написал:
   'заменить на    Dim iConnection As Object    Dim iRecordset As Object
Цитата
Nordheim написал:
   Set iConnection = CreateObject("ADODB.Connection")    Set iRecordset = CreateObject("ADODB.Recordset")
Все сделала.
Останов на листе "Средства защиты".
Код
       With isht
            .Name = Left(ikey, 30)
См. картинку.
Nordheim.JPG (20.21 КБ)
 
Цитата
Мотя написал:
Останов на листе "Средства защиты".
Посмотрите чему равно значение переменной ikey возможно в значении есть недопустимые символы  указанные в сообщении. Останов не на листе "Средства защиты" а на том который должен быть следующим.
На самом деле, код писал с применением SQL запроса, потому что, аналогичный с использованием коллекций и словарей уже можно написать на автомате не особо вдумываясь (скучно  :( ), хотелось как то разнообразить варианты выполнения задачи  :D
Изменено: Nordheim - 6 Сен 2018 11:24:26
"Все гениальное просто, а все простое гениально!!!"
 
Цитата
Nordheim написал:
цикл For Each ... Next предпочтительней цикла For ... Next. Вссе дело в скорости.
Ну ясень пень, что прямое обращение быстрее, чем через указатель. Но
Цитата
Nordheim написал:
переменную счетчик вписать в цикл
как раз эту быстроту и уничтожит за счёт всё того же пересчёта счётчика :)
 
Цитата
Nordheim написал:
Останов не на листе "Средства защиты" а на том который должен быть следующим.
Это - понятно: следующий лист - это Листi, разумеется, который предлагает сама система.  :)
Цитата
Nordheim написал:
чему равно значение переменной ikey возможно в значении есть недопустимые символы
Код
       With isht          
  .Name = Left(ikey, 30)

 
Мотя, покажите содержимое того столбца, из которого Вы берёте имена листов. А для надёжности вместо
Код
.Name = Left(ikey, 30)
впишите
Код
   Dim Bads(1 To 7) As String, Bad As Variant
   
   Bads(1) = ":"
   Bads(2) = "/"
   Bads(3) = "\"
   Bads(4) = "?"
   Bads(5) = "*"
   Bads(6) = "["
   Bads(7) = "]"
   For Each Bad In Bads
      ikey = Replace(ikey, Bad, " ", 1, -1, vbTextCompare)
   Next Bad
   .Name = Left(ikey, 31)
Изменено: StoTisteg - 6 Сен 2018 11:39:03
 
Цитата
Мотя написал:
Это - понятно: следующий лист - это Листi, разумеется
Нет не так, сама система должна создать лист(i), а вот переименовать не может, потому что недопустимое значение переменной ikey для имени листа. Прикрепите файл.
Изменено: Nordheim - 6 Сен 2018 11:41:09
"Все гениальное просто, а все простое гениально!!!"
 
Цитата
Nordheim написал:
Нет не так, сама система должна создать лист(i),
Похоже, я некорректно выразилась!
Конечно, же - сама система создала лист(i)!  :D
_________________________________
А файл - большой! В нем более 8 тыс. строк на Прайс-листе.
Изменять файл - лениво!  :D  
 
Цитата
Мотя написал:
Изменять файл - лениво!    
Удалите все столбцы кроме того на основании которого формируются листы.  Удалите дубликаты из оставшегося столбца, вся процедура займет не более 30-40 сек.
Изменено: Nordheim - 6 Сен 2018 12:23:22
"Все гениальное просто, а все простое гениально!!!"
 
Мотя, Вы моё исправление из #25 вносили? Возможно и выкладывать-то ничего не нужно.
 
Цитата
StoTisteg написал:
Вы моё исправление из #25 вносили?
Тут главное исправление внести в нужное место, если внести перед формированием переменной с запросом, то данных никаких не будет. Лучше использовать дополнительную переменную типа.
Код
Dim shtname$
shtname=Replace(ikey,....... и т.д.)
    .name = left(shtname,31)
"Все гениальное просто, а все простое гениально!!!"
Страницы: 1 2 След.
Читают тему (гостей: 1)
Наверх