Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Формирование общего списка на основании нескольких списков с условиями
 
#1
22.05.2022 23:18:05
Уважаемые форумчане, добрый вечер.

Столкнулся с проблемой формирования общего списка значений на основании нескольких второстепенных списков.

Есть 4 второстпенных списка:
  1. Вид товара
  2. Название товара
  3. Поставщики
  4. Районы

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

При этом у "Названия товара" и "Поставщиков" есть характеристики, определяющими являются столбцы "Название товара" и "Поставщики".


Планировал это сделать с помощью VBA и массивов, но не могу сообразить как из 4-х массивов записать данные в один общий. Начал писать макрос, на на записи данных в общий массив остановился:

Код
Sub CL_fr()
    Dim t!: t = Timer                   'включаем таймер
    Dim i_fr As Long, i_type, i_sp, i_r, i_CL, j, i
    Dim aType(), aFR(), aSP(), aR(), aData()
    ThisWorkbook.Worksheets("Исходные данные").Activate
    With ThisWorkbook.Worksheets("Исходные данные")
        i_type = .Cells(Rows.Count, 1).End(xlUp).Row - 1                        'определение количества видов товаров
        i_fr = .Cells(Rows.Count, 3).End(xlUp).Row - 1                          'определение количества видов фруктов
        i_sp = .Cells(Rows.Count, 7).End(xlUp).Row - 1                          'определение количества поставщиков
        i_r = .Cells(Rows.Count, 11).End(xlUp).Row - 1                          'определение количества районов
        i_CL = i_type * i_fr * i_sp * i_r                                       'определение количества позиций ведомости
        j = 9
        aType = .Range(Cells(2, 1), Cells(i_type, 1)).Value
        aFR = .Range(Cells(2, 3), Cells(i_fr, 5)).Value
        aSP = .Range(Cells(2, 7), Cells(i_sp, 9)).Value
        aR = .Range(Cells(2, 11), Cells(i_r, 11)).Value
    End With
    
    ReDim aData(1 To i_CL, 1 To j)
    Debug.Print i_CL, j
'--------------------------------------------------------------------------------------------------------------------------
    For i = 1 To UBound(aData)                                                  'копируем данные из исходных массивов в отчетный
        For j = 1 To UBound(aData, 2)
            'aData(i, j) =
        Next j
    Next i
 
    MsgBox Timer - t
End Sub

При этом есть отчетная форма для общего списка (она листе "Ведомость", порядок столбцов менять нельзя).
В качестве примера привел, то что должно в итоге получиться для Яблок и Груш. Один из столбцов ("Тип приоритета") должен формироваться по формуле (привел в файле).

Также для позиций с приоритетами 1-4 в столбцы "Кураторы" и "Телефон пост." должны присваиваться значения "Поставщика" и "Телефон кур." с приоритетом равным "Главный", затем эти строки должны менять цвет шрифта на серый.



Файл прилагаю, буду очень признателен за помощь.
 
 
 
#2
23.05.2022 00:27:03
откройте файл, выполните Main
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#3
23.05.2022 09:03:15
Цитата
написал:
откройте файл, выполните  Main
Доброе утро.
В том варианте, который вы сделали получилось 108000 позиций, хотя должно было быть 1*6*5*4=120.
Определяющими в массивах Название товара является только столбец Название товара (остальные как характеристики).
В массиве Поставщики аналогично, определяющим является столбец Поставщики (остальные также как характеристики).

И не могли бы вы рассказать логику написанного макроса.

Спасибо.
 
 
 
#4
23.05.2022 10:03:52
откройте файл, выполните Main2
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#5
23.05.2022 10:26:44
Цитата
написал:
откройте файл, выполните  Main2
Да, сейчас количество позиций верное.
Но не выполняются условия:
Цитата
Один из столбцов ("Тип приоритета") должен формироваться по формуле (привел в файле).
Цитата
Также для позиций с приоритетами не равным "Главный" (1-4) в столбцы "Кураторы" и "Телефон пост." должны присваиваться значения "Поставщика" и "Телефон кур." с приоритетом равным "Главный", затем эти строки должны менять цвет шрифта на серый.
Цитата
При этом есть отчетная форма для общего списка (она листе "Ведомость", порядок столбцов менять нельзя).
 
 
 
#6
23.05.2022 10:27:56
И Игорь, очень прошу вас рассказать как это работает, т.к. хочется разобраться, чтобы в дальнейшем попробовать реализовать подобный макрос самому.
Спасибо.
 
 
 
#7
23.05.2022 11:57:42
откройте файл, выполните Main3
Изменено: Ігор Гончаренко - 23.05.2022 11:58:01
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#8
23.05.2022 13:00:34
Цитата
написал:
откройте файл, выполните Main3
Тип приоритета добавился, порядок верный.
Но по прежнему не работает условие:
Цитата
Также для позиций с приоритетами не равным "Главный" (1-4) в столбцы "Кураторы" и "Телефон пост." должны присваиваться значения "Поставщика" и "Телефон кур." с приоритетом равным "Главный", затем эти строки должны менять цвет шрифта на серый.
 
 
 
#9
23.05.2022 13:32:37
замените Main3
на
Код
Sub Main3()
  Dim a, b, c&, cc&, d, e&, f, g, i&, j&, k&, r&, rg As Range, se, te, t&
  With Worksheets(2)
    Set rg = .Cells(.UsedRange.Row + 2 + .UsedRange.Rows.Count, 1)
    c = 1: ReDim b(1 To 1)
    Do While Not IsEmpty(.Cells(1, c))
      t = t + 1: ReDim Preserve b(1 To t): b(t) = c
      c = c + 1 + .Cells(1, c).CurrentRegion.Columns.Count
    Loop
    r = rg.Row
    For j = 1 To t
      c = b(j): b(j) = .Cells(1, c).CurrentRegion
      ReDim d(2 To UBound(b(j))): e = e + UBound(b(j), 2)
      For i = 2 To UBound(d): d(i) = i: Next
      .Cells(r, 1).Resize(1, UBound(b(j)) - 1) = d:    r = r + 1
    Next
    Rows(r - 1).ClearContents: a = Combine(rg.CurrentRegion.Value)
    ReDim Preserve a(1 To UBound(a), 1 To t)
    ReDim d(1 To UBound(a), 1 To e): rg.CurrentRegion.ClearContents
    f = .Cells(.Rows.Count, 1).End(xlUp).CurrentRegion
    For i = 1 To UBound(a)
      a(i, UBound(a, 2)) = a(i, 4)
      For c = 1 To e
        g = Split(f(1, c), ",")
        If c = 7 And d(i, 4) = "Основной" Then
          se = d(i, 5): te = d(i, 6)
        End If
        d(i, c) = b(Val(g(0)))(a(i, Val(g(0))), Val(g(1)))
        If c = 7 And d(i, 4) <> "Основной" Then
          d(i, 7) = se
        End If
        If c = 8 And d(i, 4) <> "Основной" Then
          d(i, 8) = te
        End If
      Next
    Next
    rg.Resize(UBound(d), UBound(d, 2)) = d
  End With
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#10
23.05.2022 13:51:07
Игорь, прошу прощения, в изначальной форме перепутал порядок столбцов. Необходимо поменять местами столбцы "Телефон пост." и "Телефон кур."
Но даже в текущей итерации телефоны записываются некорректно, для позиций с неглавным приоритетом одним и тем же значением заполняется столбцы "телефон пост." и "телефон кур."
 
 
 
#11
23.05.2022 14:58:43
Ещё очень хочется разобраться, как это работает. Игорь, не могли бы вы описать логику алгоритма?
 
 
 
#12
23.05.2022 15:37:11
извините, полный рассказа не осилю, а короткий мало что обьяснит
коротко это работает так:
в строке 9 в файле написано из какой группы данных из какой колонки нужно брать данные
в макросе: первые 17 строк кода - это подготовка данных для работы моей стандартной процедуры Combine, которая возвращает массив комбинаций из исходных данных
массивы данных из групп собраны в в массив В
с 20-й строки и до конца данные собираются в отчет и отчет выкладывается на лист)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
Страницы: 1
Наверх