Форум программистов
 
Контакты: о проблемах с регистрацией, почтой и по другим вопросам пишите сюда - alarforum@yandex.ru, проверяйте папку спам! Обязательно пройдите активизацию e-mail.

Вернуться   Форум программистов > Microsoft Office и VBA > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail


Донат для форума - использовать для поднятия настроения себе и модераторам

А ещё здесь можно купить рекламу за 15 тыс руб в месяц! ) пишите сюда - alarforum@yandex.ru

Ответ
 
Опции темы
Старый 20.02.2016, 00:44   #1
KotKod
Новичок
 
Аватар для KotKod
 
Регистрация: 20.02.2016
Сообщений: 2
Репутация: 10
Вопрос Перебор вариаций в двомерном масиве

Есть двомерний массив
Пример:

Нужно сделать список такого рода(перебрать все вариации но не смешивать колонки):

A one yes
A one no
A two yes
A two no
A Three yes
A Three no
B one yes
B one no
B two yes
B two no
B Three yes
B Three no
C one yes
C one no
C two yes
C two no
C Three yes
C Three no
D one yes
D one no
D two yes
D two no
D Three yes
D Three no

Сделать цикл в цикле не могу так как количество элементов на каждом уровне массива может меняться.
KotKod вне форума   Ответить с цитированием
Старый 20.02.2016, 02:57   #2
IgorGO
МегаМодератор
СуперМодератор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Адрес: УКРАЇНА, Київ
Сообщений: 9,166
Репутация: 1811

icq: 7934250
skype: i2x0,5
По умолчанию

если сначала проанализировать сколько значений в строке, то можно и цикл в цикле.
1. внесите данные в произвольный диапазон на листе
2. количество строк с данными - не ограничено
3. количество данных в каждой строке не ограничено, произвольно но не МЕНЕЕ 1 шт.
4. ЕЩЕ ОДНО ПРАВИЛО подготовки данных: все данные в строке должны быть "прижаты" к левой стороне диапазона!!!
5. Скопируйте в модуль листа этот
Код:
Sub Combine()
  Dim arr, p() As Long, up() As Long, res(), r As Long, c As Long, cnt As Long, L As Long, i As Long, j As Long, rg As Range
  Set rg = Application.InputBox("Отметьте мышью", "Укажите диапазон с данными", Type:=8)
  If rg Is Nothing Then Exit Sub Else arr = rg.Value:  L = 1
  ReDim p(0 To UBound(arr)) As Long
  ReDim up(0 To UBound(arr)) As Long
  For r = 1 To UBound(arr)
    p(r) = 1
    For c = 1 To UBound(arr, 2)
      If IsEmpty(arr(r, c)) Then Exit For Else up(r) = up(r) + 1
    Next
    L = L * up(r)
  Next
  ReDim res(1 To L, 1 To UBound(arr))
  r = 0:  p(UBound(arr)) = 0
  Do
    i = UBound(arr)
    Do While p(i) = up(i):  i = i - 1:  Loop
    p(i) = p(i) + 1:  r = r + 1
    If i < UBound(arr) Then
      For j = i + 1 To UBound(arr):  p(j) = 1:  Next
    End If
    For c = 1 To UBound(arr)
      res(r, c) = arr(c, p(c))
    Next
  Loop Until r = L
  Set rg = Application.InputBox("Ткните мышью в ячейку", "Куда выложить результаты?", Type:=8)
  If rg Is Nothing Then Set rg = Cells(ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count, 1)
  rg.Resize(L, UBound(arr)).Value = res
End Sub
6. Выполните макрос любым доступным способом
7. Макрос спросит где находятся данные и куда сложить результаты

удачи!
__________________
41001804815208 - Яндекс-деньги благодарности за удачные советы и решения можно отправлять прямо сюда)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете

Последний раз редактировалось IgorGO; 20.02.2016 в 03:00.
IgorGO вне форума   Ответить с цитированием
Старый 20.02.2016, 05:39   #3
KotKod
Новичок
 
Аватар для KotKod
 
Регистрация: 20.02.2016
Сообщений: 2
Репутация: 10
Радость

Цитата:
Сообщение от IgorGO Посмотреть сообщение
удачи!
Спасибо, все работает =) инфа есть как єто реализовывается.
KotKod вне форума   Ответить с цитированием
Старый 20.02.2016, 10:33   #4
IgorGO
МегаМодератор
СуперМодератор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Адрес: УКРАЇНА, Київ
Сообщений: 9,166
Репутация: 1811

icq: 7934250
skype: i2x0,5
По умолчанию

правильно это оформить так:
Код:
Sub Start()
  Dim arr, rg As Range
  Set rg = Application.InputBox("Отметьте мышью", "Укажите диапазон с данными", Type:=8)
  If rg Is Nothing Then Exit Sub Else arr = rg.Value:  arr = Combine(arr)
  Set rg = Application.InputBox("Ткните мышью в ячейку", "Куда выложить результаты?", Type:=8)
  If Not rg Is Nothing Then rg.Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub


'******************************************************************************
' на входе массив данных MxN, на выходе массив всех ВОЗМОЖНЫХ КОМБИНВЦИЙ ZxM,
' которые содержат по 1-му элементу из каждой строки
' Z = произв.количества элементов в строках (в строках произвольное кол-во элементов)
'
Function Combine(arr)
  Dim p() As Long, up() As Long, res(), r As Long, c As Long, cnt As Long, L As Long, i As Long, j As Long, rg As Range
  L = 1
  ReDim p(0 To UBound(arr)) As Long
  ReDim up(0 To UBound(arr)) As Long
  For r = 1 To UBound(arr)
    p(r) = 1
    For c = 1 To UBound(arr, 2)
      If IsEmpty(arr(r, c)) Then Exit For Else up(r) = up(r) + 1
    Next
    L = L * up(r)
  Next
  ReDim res(1 To L, 1 To UBound(arr))
  r = 0:  p(UBound(arr)) = 0
  Do
    i = UBound(arr)
    Do While p(i) = up(i):  i = i - 1:  Loop
    p(i) = p(i) + 1:  r = r + 1
    If i < UBound(arr) Then
      For j = i + 1 To UBound(arr):  p(j) = 1:  Next
    End If
    For c = 1 To UBound(arr)
      res(r, c) = arr(c, p(c))
    Next
  Loop Until r = L
  Combine = res
End Function
Выполните Start, а функцию Combine смело перемещайте в библиотеку функций по КОМБИНАТОРИКЕ
__________________
41001804815208 - Яндекс-деньги благодарности за удачные советы и решения можно отправлять прямо сюда)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете
IgorGO вне форума   Ответить с цитированием
Ответ

Опции темы

Ваши права в разделе
Вы не можете создавать новые темы
Вы не можете отвечать в темах
Вы не можете прикреплять вложения
Вы не можете редактировать свои сообщения

BB коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.

Быстрый переход

Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Программа перебора вариантов (изменить перебор цифровой на перебор буквенный) BArt2000 Паскаль 5 02.03.2015 13:56
поиск в масиве Apis Общие вопросы C/C++ 2 12.09.2011 05:51
Инверсия в масиве user10 Паскаль 2 18.04.2011 00:19
поиск в масиве Apis Паскаль 1 25.04.2010 23:36
ПОВТОР ЗНАЧЕНИЯ В МАСИВЕ Slavik Microsoft Office Excel 11 27.01.2009 09:13


18:39.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.