Выбор уникальных значений их группировка по критерию

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Выбор уникальных значений их группировка по критерию (Макросы/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

Ответить

Kuzmich

Дата: Среда, 26.02.2020, 22:38 | Сообщение № 2

Группа: Проверенные

Ранг: Ветеран

Сообщений: 713

Репутация: 157 ±

Замечаний: 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]

Цитата

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

Пробуйте
[vba]

Код

[/vba]Kuzmich

Сообщение отредактировал Kuzmich - Среда, 26.02.2020, 22:40

Ответить

Сообщение

Цитата

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

Пробуйте
[vba]

Код

[/vba]

Автор - Kuzmich
Дата добавления - 26.02.2020 в 22:38

InExSu

Дата: Пятница, 28.02.2020, 00:13 | Сообщение № 3

Группа: Друзья

Ранг: Ветеран

Сообщений: 648

Репутация: 96 ±

Замечаний: 0% ±

Excel 2010, 365

Привет!
Тоже вариант во вложении.
С претензией на универсальность ^-)

[vba]

Код

Sub Chess( _
  rng_2Columns As Range, _
  cell_Chess As Range)
  'http://www.excelworld.ru/forum/10-44232-1
  ' из первого столбца сделать уникальные заголовки столбцов
  ' из второго столбца накидать по заголовкам уникально

  Dim cell As Range

  For Each cell In rng_2Columns.Columns(1).Cells

    Column_Value_Add_if_NOT _
      Column_Head_Find_or_Add(cell_Chess, cell.Value), _
      cell.Offset(0, 1).Value

  Next
End Sub

Function Column_Head_Find_or_Add( _
  cell_01 As Range, _
  sVal As String) _
  As Range
  ' найти или добавить заголовок столбца
  ' вернуть ячейку заголовка

  Dim rng_find As Range

  ' заголовков ещё нет
  If cell_01.Value = "" Then

    Set rng_find = cell_01
    rng_find.Value = sVal

  Else

    Dim rng_Heads As Range

    ' заголовок одинокая ячейка
    If cell_01.Offset(0, 1).Value = "" Then
      Set rng_Heads = cell_01 ' в заголовках одна ячейка
    Else
      Set rng_Heads = cell_01.Parent.Range(cell_01, cell_01.End(xlToRight))
    End If

    Set rng_find = rng_Heads.Find(sVal)

    If rng_find Is Nothing Then
      ' добавить справа
      Set rng_find = Range_Cell_Right(rng_Heads).Offset(0, 1)

      rng_find.Value = sVal

    End If
  End If

  Set Column_Head_Find_or_Add = rng_find

End Function

Function Range_Cell_Right( _
  rng As Range) _
  As Range
  ' вернуть правую крайнюю ячейку диапазона

  If rng.Rows(1).Columns.Count = 1 Then

    Set Range_Cell_Right = rng.Rows(1)

  Else

    Set Range_Cell_Right = rng.Rows(1).End(xlToRight)

  End If
End Function

Function Column_Value_Add_if_NOT( _
  cell_Head As Range, _
  sVal As String)
  ' найти в столбце значение, если нет
  ' добавить вниз

  ' ниже заголовка значений пока нет
  If cell_Head.Offset(1, 0).Value = "" Then

    cell_Head.Offset(1, 0).Value = sVal

  Else

    Dim rng_Columns As Range
    Set rng_Columns = cell_Head.Parent.Range(cell_Head, cell_Head.End(xlDown))

    Dim rng_find As Range
    Set rng_find = rng_Columns.Find(sVal)

    If rng_find Is Nothing Then

      rng_Columns.End(xlDown).Offset(1, 0).Value = sVal

    End If
  End If
End Function

[/vba]

Привет!
Тоже вариант во вложении.
С претензией на универсальность ^-)

[vba]

Код