Страницы: 1
RSS
Расписание из случайных значений без повторов
 
Добрый день. Подскажите, пожалуйста, как можно заполнять список по формуле без повторов. Имеется табличка с расписанием на 11 часов, каждый час есть несколько вариантов (указанны справа)
Значение в столбце не должно повторятся. Вот этот момент не смогла формулой сделать(
Пробовала всякие случайные, если. Не вышло, помогите, пожалуйста
Выпадающие списки тоже неудобны=(
 
Цитата
Skittish написал: есть несколько вариантов (указанны справа)
Справа от чего? Непонятно откуда что брать.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
Цветным это основная таблица. Справа от нее без фона значения для ячеек в этой строке
 
, то есть в 8-9 может быть только четвертый, первый, второй и третий
9-10 и 10-11 все могут быть значения
 
Skittish, я не вижу решения формулой без повторов. ИМХО, писать макрос, который заполняет интервалы по дням начиная с интервалов с наименьшим кол-ом допустимых вариантов. Если Вас устроит макрос - попробую написать.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
 , да конечно, спасибо большое.
 
Вариант макросом.
Код
Sub Заполнить()
    JobRange Range("B2:F12"), Range("G2:R12")
End Sub

Private Sub JobRange(r1 As Range, r2 As Range)
    Dim ar1 As Variant
    Dim ar2 As Variant
    ReDim ar1(1 To r1.Rows.Count, 1 To r1.Columns.Count)
    ar2 = r2
    
    Dim dic As Object
    Dim y1 As Long
    Dim y2 As Long
    Dim x1 As Long
    Dim x2 As Long
    Dim iRnd As Long
    Randomize
    For y1 = 1 To UBound(ar1, 1)
        Set dic = CreateObject("Scripting.Dictionary")
        dic.CompareMOde = 1
        For x1 = 1 To UBound(ar1, 2)
            For x2 = 1 To UBound(ar2, 2)
                If ar2(y1, x2) <> "" Then
                    dic.Item(ar2(y1, x2)) = 0
                End If
            Next
            For x2 = 1 To UBound(ar1, 2)
                If dic.Exists(ar1(y1, x2)) Then
                    dic.Remove ar1(y1, x2)
                End If
            Next
            For y2 = 1 To y1 - 1
                If dic.Exists(ar1(y2, x1)) Then
                    dic.Remove ar1(y2, x1)
                End If
            Next
            If dic.Count > 0 Then
                iRnd = Int(Rnd * dic.Count)
                ar1(y1, x1) = dic.Keys()(iRnd)
            End If
'            r1 = ar1
'            Stop
        Next
    Next
    r1 = ar1
End Sub
 
Спасибо. Запустила, все работает, только почему-то 5 пустых ячеек


Из-за количества вариантов наверно. В строке они могут повториться.  Это не очень сложно дописать? И возможно ли? Например, последняя строка "шестой восьмой шестой восьмой шестой"
Или как то ее зафиксировать чтоб ее не пересчитывало
Изменено: Skittish - 18.04.2022 12:23:32
 
Так в строке могут повторяться.
Код
'v2
Sub Заполнить()
    JobRange Range("B2:F12"), Range("G2:R12")
End Sub

Private Sub JobRange(r1 As Range, r2 As Range)
    Dim ar1 As Variant
    Dim ar2 As Variant
    ReDim ar1(1 To r1.Rows.Count, 1 To r1.Columns.Count)
    ar2 = r2
    
    Dim dic As Object
    Dim y1 As Long
    Dim y2 As Long
    Dim x1 As Long
    Dim x2 As Long
    Dim iRnd As Long
    Randomize
    For y1 = 1 To UBound(ar1, 1)
        Set dic = CreateObject("Scripting.Dictionary")
        dic.CompareMOde = 1
        For x1 = 1 To UBound(ar1, 2)
            For x2 = 1 To UBound(ar2, 2)
                If ar2(y1, x2) <> "" Then
                    dic.Item(ar2(y1, x2)) = 0
                End If
            Next
            For x2 = 1 To UBound(ar1, 2)
                If dic.Exists(ar1(y1, x2)) Then
                    dic.Remove ar1(y1, x2)
                End If
            Next
            For y2 = 1 To y1 - 1
                If dic.Exists(ar1(y2, x1)) Then
                    dic.Remove ar1(y2, x1)
                End If
            Next
            If dic.Count > 0 Then
                iRnd = Int(Rnd * dic.Count)
                ar1(y1, x1) = dic.Keys()(iRnd)
            End If
            
            If ar1(y1, x1) = "" Then
                For x2 = 1 To UBound(ar2, 2)
                    If ar2(y1, x2) <> "" Then
                        dic.Item(ar2(y1, x2)) = 0
                    End If
                Next
                For y2 = 1 To y1 - 1
                    If dic.Exists(ar1(y2, x1)) Then
                        dic.Remove ar1(y2, x1)
                    End If
                Next
                If dic.Count > 0 Then
                    iRnd = Int(Rnd * dic.Count)
                    ar1(y1, x1) = dic.Keys()(iRnd)
                End If
            End If
            
        Next
    Next
    r1 = ar1
End Sub
 
МатросНаЗебре, Последняя строка не стают значения, 1-2 и все=(
простите, пожалуйста, за беспокойство, просто хотела понять что да как
Изменено: Skittish - 18.04.2022 13:54:29
 
Цитата
написал:
Последняя строка не стают значения
Эти значения в столбце уже есть.
 
,а можно как то порядок заполнения поменять? мол сначала 8-9, потом 18-19
 
Код
'v3
Sub Заполнить()
    Dim ar1 As Variant
    JobRange Range("B2:F12"), Range("G2:R12"), ar1, 11
    JobRange Range("B2:F12"), Range("G2:R12"), ar1, 0
End Sub

Private Sub JobRange(r1 As Range, r2 As Range, ar1 As Variant, workRow As Long)
    Dim ar2 As Variant
    If IsEmpty(ar1) Then ReDim ar1(1 To r1.Rows.Count, 1 To r1.Columns.Count)
    ar2 = r2
    
    Dim dic As Object
    Dim y1 As Long
    Dim y2 As Long
    Dim x1 As Long
    Dim x2 As Long
    Dim iRnd As Long
    Randomize
    For y1 = IIf(workRow = 0, 1, workRow) To IIf(workRow = 0, UBound(ar1, 1), workRow)
        Set dic = CreateObject("Scripting.Dictionary")
        dic.CompareMOde = 1
        For x1 = 1 To UBound(ar1, 2)
            For x2 = 1 To UBound(ar2, 2)
                If ar2(y1, x2) <> "" Then
                    dic.Item(ar2(y1, x2)) = 0
                End If
            Next
            For x2 = 1 To UBound(ar1, 2)
                If dic.Exists(ar1(y1, x2)) Then
                    dic.Remove ar1(y1, x2)
                End If
            Next
            For y2 = 1 To UBound(ar1, 1)
                If y1 <> y2 Then
                    If dic.Exists(ar1(y2, x1)) Then
                        dic.Remove ar1(y2, x1)
                    End If
                End If
            Next
            If dic.Count > 0 Then
                iRnd = Int(Rnd * dic.Count)
                ar1(y1, x1) = dic.Keys()(iRnd)
            End If
            
            If ar1(y1, x1) = "" Then
                For x2 = 1 To UBound(ar2, 2)
                    If ar2(y1, x2) <> "" Then
                        dic.Item(ar2(y1, x2)) = 0
                    End If
                Next
                For y2 = 1 To UBound(ar1, 1)
                    If y1 <> y2 Then
                        If dic.Exists(ar1(y2, x1)) Then
                            dic.Remove ar1(y2, x1)
                        End If
                    End If
                Next
                If dic.Count > 0 Then
                    iRnd = Int(Rnd * dic.Count)
                    ar1(y1, x1) = dic.Keys()(iRnd)
                End If
            End If
            
        Next
    Next
    r1 = ar1
End Sub
 
,вы просто волшебник) спасибо большое)
Страницы: 1
Наверх