Страницы: 1
RSS
получить все возможные варианты из матрицы, автоматическое создание всех возможных вариантов.
 
Добрый день, есть матрица которая разделена на 5 колонок в каждой колонке по 3 числа от 1 до 15, в разной последовательности и каждая матрица из этих пяти имеет разную длину, вопрос как записать все возможные комбинации от 1 до 15. формулами это понятно как делается (перемножение количества столбцов между собой)
8*7*8*7*4 = 12 544
 
Код
Option Explicit

Sub Перебор()
    Dim arr As Variant
    ReDim arr(1 To 5)
    With ActiveSheet
        arr(1) = .Range("A2").Resize(9, 3)
        arr(2) = .Range("E2").Resize(8, 3)
        arr(3) = .Range("I2").Resize(9, 3)
        arr(4) = .Range("M2").Resize(8, 3)
        arr(5) = .Range("Q2").Resize(5, 3)
    End With
    
    Dim u As Long
    Dim x As Integer
    u = 1
    Dim v As Variant
    For Each v In arr
        u = u * (UBound(v, 1) - 1)
        x = x + UBound(v, 2)
    Next
    If u > 0 Then
        Dim brr As Variant
        ReDim brr(1 To u + 1, 1 To x)
    
        Dim y1 As Long
        Dim y2 As Long
        Dim y3 As Long
        Dim y4 As Long
        Dim y5 As Long
        
        For x = 1 To UBound(brr, 2)
            brr(1, x) = x
        Next
        u = 1
        For y1 = 2 To UBound(arr(1), 1)
        For y2 = 2 To UBound(arr(2), 1)
        For y3 = 2 To UBound(arr(3), 1)
        For y4 = 2 To UBound(arr(4), 1)
        For y5 = 2 To UBound(arr(5), 1)
            u = u + 1
            For x = 1 To UBound(arr(1), 2)
                brr(u, arr(1)(1, x)) = arr(1)(y1, x)
                brr(u, arr(2)(1, x)) = arr(2)(y2, x)
                brr(u, arr(3)(1, x)) = arr(3)(y3, x)
                brr(u, arr(4)(1, x)) = arr(4)(y4, x)
                brr(u, arr(5)(1, x)) = arr(5)(y5, x)
            Next
        Next
        Next
        Next
        Next
        Next
        
        With Workbooks.Add(1)
            With .Sheets(1)
                With .Cells(1, 1).Resize(UBound(brr, 1), UBound(brr, 2))
                    .Value = brr
                End With
            End With
            .Saved = True
        End With
    End If
End Sub
 
DJMC, здравствуйте
Попробуйте применить Генератор фраз из заданных фрагментов
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
МатросНаЗебре
спасибо за решение, то что мне нужно было.
Изменено: DJMC - 22.10.2021 10:41:48
 
Цитата
МатросНаЗебре написал:
Код
If u > 0 Then        
Dim brr As Variant
Скажите, пожалуйста, а в чём сакральный смысл объявлять переменную в блоке If? Разве не правильнее объявить ВСЕ переменные в начале кода?
 
Цитата
Неопытный_Экселист написал:
Разве не правильнее объявить ВСЕ переменные в начале кода?
У Вас есть какое-нибудь рациональное объяснение "правильности"?
 
Неопытный_Экселист, возможно, это что-то вроде экономии памяти, однако я ни разу не встречал практической полезности такого подхода, а вот стилистически неудобно (но это уже вкусовщина)

Цитата
Неопытный_Экселист: Разве не правильнее
это не "правильность" (правильность - это, что 2*2 = 4) — это принятый шаблон (несколько людей просто договорились, что так "удобно") - самое забавное, что в разных языках отношение к этому может кардинально отличаться  :D
Изменено: Jack Famous - 22.10.2021 11:56:56
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Неважно, в каком месте процедуры размещена переменная - память она занимает сразу при старте процедуры.
Иногда объявление переменных размещают или непосредственно там, где они начинают использоваться, или в начале блоков кода, в которых она будет использована. Это никак не влияет на работу программы.
Как по мне, такое размещение ухудшает читаемость кода. Правильнее все переменные объявлять в самом начале процедуры, одним блоком. Но это мое субъективное мнение.
 
Цитата
vikttur: Неважно, в каком месте процедуры размещена переменная - память она занимает сразу при старте процедуры
тем более — тогда просто стиль такой, значит. Меня за метки часто ругают, например  :D

Цитата
vikttur: Правильнее
:D
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Раньше переменные всегда объявлял в начале процедуры/функции.
Потом заметил, что при редактировании кода, удобнее, если объявление переменной выполнено близко к первому использованию. В случае переименования или удаления переменной надо будет меньше скролить вверх. И раз это не противоречит требованиям языка, то максимизация по удобству редактирования выглядит достаточно разумной.
 
МатросНаЗебре
Добрый день, подскажите можно сделать так чтобы макрос не выводил пустые значения, а сразу считал сколько столбцов в матрице и брал их значения, если я правильно понял код :

Код
Sub Перебор()
    Dim arr As Variant
    ReDim arr(1 To 5)
    With ActiveSheet
        arr(1) = .Range("A2").Resize(9, 3)
        arr(2) = .Range("E2").Resize(8, 3)
        arr(3) = .Range("I2").Resize(9, 3)
        arr(4) = .Range("M2").Resize(8, 3)
        arr(5) = .Range("Q2").Resize(5, 3)
    End With

то тут задается четкое количество сравнений
 
Off
Цитата
vikttur написал: Как по мне, ... Правильнее... но это мое субъективное мнение
Структура, когда Dim'ы не рвут код. У кого-то другая "правильность" и это не мешает писать хорошо работающие программы

Цитата
МатросНаЗебре написал: В случае переименования или удаления переменной надо будет меньше скролить вверх
Не убедил. Часто они удаляются/переименовываются?  Это не наш метод :)
Можно после создания и проверки кода причесать его, а объявления переменных вынести наверх.

Игорь как-то писал (не дословно): надо стараться писать так, чтобы вся процедура была видна на экране. Полностью поддерживаю.  Это не только избавит от лишних  прокруток, но и сделает код более читаемым - вся программа будет разбита на логически завершенные блоки. Ведь писать/читать/редактировать код, в котором одна строка заменяет десяток, намного проще, чем длинную простыню.

Пример отдельных процедур: стартовые установки (например, отключения обновления экрана и сообщений), открытие файла или папки, получение в массив данных из файла или листа, непосредственно обработка данных (эта процедура тоже может передавать управление другим Sub или Function), создание книги, выгрузка результата на лист, финишные установки.

Еще один плюс блочной конструкции - легче писать новые программы, вставляя в нее нужные макросы.
 
Цитата
vikttur: надо стараться писать так, чтобы вся процедура была видна на экране
О модульном подходе
Полностью согласен - нужно разбивать код, однако нужно также помнить, что при передаче/вызове в цикле можно потерять время/скорость

Цитата
vikttur: плюс блочной конструкции - легче писать новые программы, вставляя в неё нужные макросы
если эти отдельные процедуры/функции самостоятельны, то да, а у меня часто бывает, что одна процедура/функция вызывает ещё 3 ,которые вызывают ещё по 5  :D
Приходится прямо модулями переносить, зато при апдейте "корневых" процедур, у всех вызывающих всегда новый "движок"  :idea:

Такую тему затронул - сейчас натопим  :D
Изменено: Jack Famous - 25.10.2021 09:42:38
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
DJMC написал:
сразу считал сколько столбцов
В таком варианте, макрос будет сам определять ширину и высоту диапазонов, которые ранее задавались как Range("A2").Resize(9, 3), Range("E2").Resize(8, 3)...
Код
Option Explicit
'v2
Sub Перебор()
    Dim arr As Variant
    arr = GetArr(ActiveSheet)
    If IsEmpty(arr) Then Exit Sub
    If UBound(arr) < 5 Then Exit Sub
    
    Dim u As Long
    Dim x As Integer
    u = 1
    Dim v As Variant
    For Each v In arr
        u = u * (UBound(v, 1) - 1)
        x = x + UBound(v, 2)
    Next
    If u > 0 Then
        Dim brr As Variant
        ReDim brr(1 To u + 1, 1 To x)
     
        Dim y1 As Long
        Dim y2 As Long
        Dim y3 As Long
        Dim y4 As Long
        Dim y5 As Long
        Dim yZ As Long
        Dim z As Byte
         
        For x = 1 To UBound(brr, 2)
            brr(1, x) = x
        Next
        u = 1
        For y1 = 2 To UBound(arr(1), 1)
        For y2 = 2 To UBound(arr(2), 1)
        For y3 = 2 To UBound(arr(3), 1)
        For y4 = 2 To UBound(arr(4), 1)
        For y5 = 2 To UBound(arr(5), 1)
            u = u + 1
            
            For z = 1 To 5
                Select Case z
                Case 1: yZ = y1
                Case 2: yZ = y2
                Case 3: yZ = y3
                Case 4: yZ = y4
                Case 5: yZ = y5
                End Select
                For x = 1 To UBound(arr(z), 2)
                    brr(u, arr(z)(1, x)) = arr(z)(yZ, x)
                Next
            Next
        Next
        Next
        Next
        Next
        Next
         
        With Workbooks.Add(1)
            With .Sheets(1)
                With .Cells(1, 1).Resize(UBound(brr, 1), UBound(brr, 2))
                    .Value = brr
                End With
            End With
            .Saved = True
        End With
    End If
End Sub

Function GetArr(sh As Worksheet) As Variant
    With sh
        With .Range("A11")
            If .Value = "ВСЕГО ДОЛЖНО ПОЛУЧИТСЯ ВАРИАНТОВ" Then .Clear
        End With
        
        Dim y As Long
        Dim x As Integer
        Dim arr As Variant
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        Dim r As Range
        Set r = .Cells(2, 1)
        Do
            x = r.End(xlToRight).Column
            y = r.End(xlDown).Row
            If x = .Columns.Count Then Exit Do
            If y < .Rows.Count Then
                arr = r.Resize(y - r.Row + 1, x - r.Column + 1)
                r.Resize(y - r.Row + 1, x - r.Column + 1).Select
                dic.Item(dic.Count + 1) = arr
            End If
            Set r = .Cells(r.Row, x + 2)
        Loop
        If dic.Count > 0 Then
            ReDim arr(1 To dic.Count)
            Dim irr As Variant
            irr = dic.Items()
            For x = 1 To dic.Count
                arr(x) = irr(x - 1)
            Next
            GetArr = arr
        End If
    End With
End Function
     


Цитата
DJMC написал:
чтобы макрос не выводил пустые значения
Слишком размытое требование. Макрос и не выводил пустые значения на начальном примере.
 
Цитата
Jack Famous написал:
Такую тему затронул - сейчас натопим
Замабувараев на Киберфоруме давал ссылку на книгу "Чистый код" (Роберт Мартин): http://download.blackball.lv/data/library/Chistyj_kod_-_Sozdanie_analiz_i_refaktoring_%282013%29.pdf
Где описываются подходы к профессиональному программированию, когда код нужно еще и сопровождать в последствии

Книгу до конца не осилил, но в ней много полезного
Изменено: MCH - 25.10.2021 12:00:02
 
Цитата
Абсолютно необходимо знать, где что находится — и в этом помогают такие методы, как грамотный выбор имен...
Фрагмент кода должен находиться там, где читатель кода ожидает его найти...
...о загромождении кода комментариями и закомментированными строками кода...
...последовательный стиль применения отступов является одним из самых статистически значимых признаков низкой плотности ошибок...
Если ... аккуратно разложенные инструменты [читай - фрагменты кода] повышают производительность, то я обеими руками «за».
И это только в предисловии (его я уже осилил :) )

Михаил, спасибо, заинтриговал. Гружу книгу в книжку ), буду читать по дороге. Листинги, похоже, не должны этому мешать (в том смысле, что код не обязательно набирать и проверять)
 
Цитата
МатросНаЗебре написал:
Слишком размытое требование. Макрос и не выводил пустые значения на начальном примере.
раньше почему то были пустые ячейки, сейчас все работает как часики, большое Вам спасибо за помощь.
 
MCH, благодарю  ;)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Страницы: 1
Наверх