Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Выбор уникальных значений их группировка по критерию - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Выбор уникальных значений их группировка по критерию (Макросы/Sub)
Выбор уникальных значений их группировка по критерию
alex112524 Дата: Среда, 26.02.2020, 20:24 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Добрый день!

Пожалуйста, подскажите решение проблемы или, хотя бы, направление, куда "копать".

В прилагаемом файле есть поле ДАННЫЕ, которое состоит из комбинаций Категорий и Товаров. Товар может относятся только к одной категории. Комбинации пары Категория-Товар могут повторяться неоднократно.

Задача: через VBA получить матрицу, на подобие той, которая указана в файле, где по горизонтали идет список всех Категорий, а под каждой категорией список уникальных значений Товаров, которые встречаются в Данных и которые относятся к данной категории.

На практике, данных более 10 тыс. строк, категорий - несколько десятков. Единственный способ, до которого я додумался, это через коллекции, но при создании нескольких десятков коллекций наступил тупик. Возможно, есть другой способ, более рациональный?
К сообщению приложен файл: 9555949.xlsx(9.3 Kb)


Сообщение отредактировал alex112524 - Среда, 26.02.2020, 20:26
 
Ответить
СообщениеДобрый день!

Пожалуйста, подскажите решение проблемы или, хотя бы, направление, куда "копать".

В прилагаемом файле есть поле ДАННЫЕ, которое состоит из комбинаций Категорий и Товаров. Товар может относятся только к одной категории. Комбинации пары Категория-Товар могут повторяться неоднократно.

Задача: через VBA получить матрицу, на подобие той, которая указана в файле, где по горизонтали идет список всех Категорий, а под каждой категорией список уникальных значений Товаров, которые встречаются в Данных и которые относятся к данной категории.

На практике, данных более 10 тыс. строк, категорий - несколько десятков. Единственный способ, до которого я додумался, это через коллекции, но при создании нескольких десятков коллекций наступил тупик. Возможно, есть другой способ, более рациональный?

Автор - alex112524
Дата добавления - 26.02.2020 в 20:24
Kuzmich Дата: Среда, 26.02.2020, 22:38 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 682
Репутация: 150 ±
Замечаний: 0% ±

Excel 2003
Цитата
через VBA получить матрицу

Пробуйте
[vba]
Код
Sub KategorTowar()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim dict As Object
Dim n As Integer
Dim k As Integer
Dim FoundKategor As Range
Dim FAdr As String
Application.ScreenUpdating = False
iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   Range("D2:D" & iLastRow).Clear
Range("A2:A" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("D2"), Unique:=True
iLR = Cells(Rows.Count, "D").End(xlUp).Row
   n = iLR - 2          'число уникальных категорий
    Range(Cells(1, 8), Cells(iLastRow, 8 + n)).Clear
For i = 3 To iLR       'цикл по уникальным категориям
   Set dict = CreateObject("Scripting.Dictionary")
     Set FoundKategor = Columns(1).Find(Cells(i, "D"), , xlValues, xlWhole)
     If Not FoundKategor Is Nothing Then
        FAdr = FoundKategor.Address
        Do
          dict.Item(CStr(FoundKategor.Offset(, 1))) = dict.Item(CStr(FoundKategor.Offset(, 1))) + 1
           Set FoundKategor = Columns(1).FindNext(FoundKategor)
        Loop While FoundKategor.Address <> FAdr
      End If
         Cells(2, 6 + i) = Cells(i, "D")
         Cells(3, 6 + i).Resize(dict.Count) = Application.Transpose(dict.keys)
Next
      Range("I1").Resize(, n).MergeCells = True
      Range("I1") = "Категории"
      Range("I1").HorizontalAlignment = xlCenter
      Range("I1").Resize(, n).BorderAround Weight:=xlThin
      Range("H2").Resize(, n + 1).Borders.Weight = xlThin
k = Range(Cells(1, 8), Cells(iLastRow, 8 + n)).Find("*", Range("I1"), xlValues, xlWhole, xlByRows, xlPrevious).Row
      Range("I2").Resize(k - 1, n).Borders.Weight = xlThin
      Range("H3").Resize(k - 2).MergeCells = True
      Range("H3") = "Товары"
      Range("H3").VerticalAlignment = xlCenter
      Range("H3").Resize(k - 2).BorderAround Weight:=xlThin
      Columns(4).Clear
Application.ScreenUpdating = True  
End Sub
[/vba]


Сообщение отредактировал Kuzmich - Среда, 26.02.2020, 22:40
 
Ответить
Сообщение
Цитата
через VBA получить матрицу

Пробуйте
[vba]
Код
Sub KategorTowar()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim dict As Object
Dim n As Integer
Dim k As Integer
Dim FoundKategor As Range
Dim FAdr As String
Application.ScreenUpdating = False
iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   Range("D2:D" & iLastRow).Clear
Range("A2:A" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("D2"), Unique:=True
iLR = Cells(Rows.Count, "D").End(xlUp).Row
   n = iLR - 2          'число уникальных категорий
    Range(Cells(1, 8), Cells(iLastRow, 8 + n)).Clear
For i = 3 To iLR       'цикл по уникальным категориям
   Set dict = CreateObject("Scripting.Dictionary")
     Set FoundKategor = Columns(1).Find(Cells(i, "D"), , xlValues, xlWhole)
     If Not FoundKategor Is Nothing Then
        FAdr = FoundKategor.Address
        Do
          dict.Item(CStr(FoundKategor.Offset(, 1))) = dict.Item(CStr(FoundKategor.Offset(, 1))) + 1
           Set FoundKategor = Columns(1).FindNext(FoundKategor)
        Loop While FoundKategor.Address <> FAdr
      End If
         Cells(2, 6 + i) = Cells(i, "D")
         Cells(3, 6 + i).Resize(dict.Count) = Application.Transpose(dict.keys)
Next
      Range("I1").Resize(, n).MergeCells = True
      Range("I1") = "Категории"
      Range("I1").HorizontalAlignment = xlCenter
      Range("I1").Resize(, n).BorderAround Weight:=xlThin
      Range("H2").Resize(, n + 1).Borders.Weight = xlThin
k = Range(Cells(1, 8), Cells(iLastRow, 8 + n)).Find("*", Range("I1"), xlValues, xlWhole, xlByRows, xlPrevious).Row
      Range("I2").Resize(k - 1, n).Borders.Weight = xlThin
      Range("H3").Resize(k - 2).MergeCells = True
      Range("H3") = "Товары"
      Range("H3").VerticalAlignment = xlCenter
      Range("H3").Resize(k - 2).BorderAround Weight:=xlThin
      Columns(4).Clear
Application.ScreenUpdating = True  
End Sub
[/vba]

Автор - Kuzmich
Дата добавления - 26.02.2020 в 22:38
InExSu Дата: Пятница, 28.02.2020, 00:13 | Сообщение № 3
Группа: Друзья
Ранг: Ветеран
Сообщений: 644
Репутация: 96 ±
Замечаний: 0% ±

Excel 2010
Привет!
Тоже вариант во вложении.
С претензией на универсальность ^-)
К сообщению приложен файл: 4158757.xls(45.0 Kb)


Разработчик Битрикс24, Google Apps Script, VBA
 
Ответить
СообщениеПривет!
Тоже вариант во вложении.
С претензией на универсальность ^-)

Автор - InExSu
Дата добавления - 28.02.2020 в 00:13
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Выбор уникальных значений их группировка по критерию (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2022 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!