Страницы: 1
RSS
Подбор к комбинации из шести чисел неизвестных слагаеммых(от 1 до 49) к желаемой сумме слагаеммых
 
Здравствуйте Уважаемые Форумчане!                                
                                           
   Нужна Ваша помощь! Помогите пожалуйста, если это возможно!                                        
   Нужно сделать Подбор к комбинации из 6 чисел неизвестных слагаемых(от 1 до 49) к желаемой сумме                                        
   в случае, если известны в комбинации из 6 чисел только 3 или 4 или 5 чисел.                                        
   Нужно использовать все возможные слагаемые(от 1 до 49), чтобы получить желаемую сумму.                                        
   Ну а если не найдутся не известные слагаемые к желаемой сумме, то тогда буду  к комбинации из 6 чисел                                        
   с известными слагаемыми(3 или 4 или 5 числами) выбирать другую желаемую сумму.                                        
                                           
   Известные слагаемые в комбинации из 6 чисел при этом не меняются.                                        
   У меня Эксцель-2007!                                        
   Нужен Эксцель-макрос и кнопка в верхнем правом углу.                                        
   Спасибо Вам большое! Постарался пошагово объяснить!
Всё остальное в файле-примере Эксцель!
Изменено: vikttur - 16.09.2021 20:44:39
 
Цитата
Cristal написал:
Эксцель
кровь из глаз идёт, когда вы программу Excel (в русском произношении "Эксел(ь)", в английском "Иксел" ([ɪkˈsel])) называете "Эксцель"
Изменено: New - 16.09.2021 20:33:18
 
New,  8-0  
Не бойтесь совершенства. Вам его не достичь.
 
Цитата
New написал:
Иксел" ([ɪkˈsel]))
Спасибо за подмеченную неправильность! Будем учить английский!
 
Mershik, не, а что он обижает нашу любимую программу ))  Cristal, это шутка, не обижайтесь, пожалуйста.
Изменено: New - 16.09.2021 22:55:09
 
Цитата
New: кровь из глаз идёт, когда вы программу Excel (в русском произношении "Эксел(ь)", в английском "Иксел" ([ɪkˈsel])) называете "Эксцель"
если про кровь именно из ГЛАЗ, то лично меня "иксэл" ранит куда больше, чем "Эксцэль", в котором, по сути одна буква только лишняя
В фонетическом же смысле эта "ц" вообще игнорируется и в итоге слово звучит вполне себе нормально  :)
Изменено: Jack Famous - 17.09.2021 10:04:25
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Код
Option Explicit

Sub Спортлото()
    Dim arr As Variant
    arr = GetArr(Range("A1:G1"))
    Range("B2").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub

Function GetArr(r As Range) As Variant
    Dim s As Long
    s = r.Cells(1, 1).Value
    Dim arr As Variant
    arr = r.Range("B1:G1")
    Dim x As Long
    Dim y As Long
    y = 1
    For x = UBound(arr, 2) To 1 Step -1
        If arr(1, x) = "" Then
            y = y * 49
        End If
    Next
    Dim brr As Variant
    If y > Rows.Count - 2 Then y = Rows.Count - 2
    ReDim brr(1 To y, 1 To 6)
    If y > 1 Then
        Dim i1 As Byte
        Dim i2 As Byte
        Dim i3 As Byte
        Dim i4 As Byte
        Dim i5 As Byte
        Dim i6 As Byte
        y = 0
        
        For i1 = IIf(arr(1, 1) = "", 1, arr(1, 1)) To IIf(arr(1, 1) = "", 49, arr(1, 1))
        For i2 = IIf(arr(1, 2) = "", 1, arr(1, 2)) To IIf(arr(1, 2) = "", 49, arr(1, 2))
        For i3 = IIf(arr(1, 3) = "", 1, arr(1, 3)) To IIf(arr(1, 3) = "", 49, arr(1, 3))
        For i4 = IIf(arr(1, 4) = "", 1, arr(1, 4)) To IIf(arr(1, 4) = "", 49, arr(1, 4))
        For i5 = IIf(arr(1, 5) = "", 1, arr(1, 5)) To IIf(arr(1, 5) = "", 49, arr(1, 5))
        For i6 = IIf(arr(1, 6) = "", 1, arr(1, 6)) To IIf(arr(1, 6) = "", 49, arr(1, 6))
            If s = i1 + i2 + i3 + i4 + i5 + i6 Then
                y = y + 1
                brr(y, 1) = i1
                brr(y, 2) = i2
                brr(y, 3) = i3
                brr(y, 4) = i4
                brr(y, 5) = i5
                brr(y, 6) = i6
            End If
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
    End If
    GetArr = brr
End Function
 
Cristal
посмотрел твою задумку, мне кажется тут очень сложно "взломать" таким способом лотерею,
вот из твоего примера Известно 3 числа: 1-2-10    Желаемая сумма 123
Нужно найти все комбинации с неизвестными числами под сумму 123
получается у тебя тут получается сумма всего 13, тебе нужно найти любые три числа от 1 до 49 чтобы в сумме получилось 120, плюс не совсем понятно может ли одно число повторятся дважды?
 
Цитата
DJMC: Известно 3 числа: 1-2-10    Желаемая сумма 123… у тебя сумма всего 13, нужно найти любые три числа от 1 до 49 чтобы в сумме получилось 120
просто удивительно, как у вас НЕ получается не только СВОИ вопросы объяснить, но чужие ПОНЯТНЫЕ — ЗАПУТАТЬ  :D
Изменено: Jack Famous - 17.09.2021 10:54:34
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
DJMC написал:
тут очень сложно "взломать" таким способом лотерею
взломать лотерею, в которой каждый следующий розыгрыш является СЛУЧАЙНЫМ и НИКАК НЕ ЗАВИСИТ ОТ ВСЕХ ПРЕДЫДУЩИХ - не возможно
спросите у любого что хоть самую малость понимает в азах математики
понимаете? вероятность того что в след. розыгрыше выпадет 1,2,3,4,5,6 точно такая же как вероятность выпасти ЛЮБЫМ другим 6 числам, ЛЮБЫМ! даже тем 6-и, что выпали в прошлом розыгрыше, потому что этот от прошлого НИКАК не зависит
удачи вам!
Изменено: Ігор Гончаренко - 17.09.2021 11:16:11
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
Jack Famous написал:
как у вас НЕ получается не только СВОИ вопросы объяснить, но чужие
вопрос нужно задать так чтобы никто не смог угадать систему выигрыша
а то угадают и понабегут выигрывать вместо DJMC,
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Спасибо Вам большое МатросНаЗебре!!
Попробовал я этот код выдаёт ошибку!
В разных местах листа я размещал комбинации, выдаёт ошибку одну и тожу!
Могли бы Вы выставить Макрос Excel-файл с примерами, хотелось бы глянуть как у Вас работает!
Гляньте на код с ошибкой на картинке!
Спасибо за код и за то, что не прошли мимо и не остались равнодушными
Изменено: vikttur - 21.09.2021 09:07:20
 
В A1 напишите 123
В B1:D1
1210
Результат выведет во вторую строку и ниже.
 
Вот это да! Настоящее чудо произошло! Радости у меня как у ребёнка!
С такими как Вы не страшно в бой идти! При моей удаче в игре, я Вас не забуду! Обязательно Вас я отблагадарю финансово. А я надеюсь на успех и удачу!
Кроме всего прочего Вам преогромное спасибо! Оставайтесь здоровыми и успешными!
Нет слов от успеха!  
 
МатросНаЗебре, я прошу прощения, если я Вас отвлекаю от дел!
Можно ли как то это исправить?
Генерируется какая то комбинация например 1 2 10 35 36 39
Первые 3 числа остаются  без изменений-это нормально!
Создаются еще дополнительные дубли этой комбинации Например: 1 2 10 36 35 39 или 1 2 10 39 35 39
То есть создались лишние дубли с перестановкой 3 последних чисел
А также в комбинации повторяются одинаковые числа например: 1 2 10 36 36 38 или 1 2 10 36 38 36
Спасибо! Прилагаю фото.
Изменено: vikttur - 17.09.2021 20:37:48
 
У меня получилось такое решение, исключающее повторы, работает достаточно быстро
Изменено: MCH - 20.09.2021 09:30:47
 
#7 без повторов.
Код
Sub Спортлото89()
    Dim arr As Variant
    arr = GetArr(Range("A1:G1"))
    Range("B2").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub

Function GetArr(r As Range) As Variant
    Dim s As Long
    s = r.Cells(1, 1).Value
    Dim arr As Variant
    arr = r.Range("B1:G1")
    Dim x As Long
    Dim y As Long
    y = 1
    For x = UBound(arr, 2) To 1 Step -1
        If arr(1, x) = "" Then
            y = y * 49
        End If
    Next
    Dim brr As Variant
    If y > Rows.Count - 2 Then y = Rows.Count - 2
    ReDim brr(1 To y, 1 To 6)
    If y > 1 Then
        Dim i1 As Byte
        Dim i2 As Byte
        Dim i3 As Byte
        Dim i4 As Byte
        Dim i5 As Byte
        Dim i6 As Byte
        y = 0
        
        For i1 = IIf(arr(1, 1) = "", 1, arr(1, 1)) To IIf(arr(1, 1) = "", 49, arr(1, 1))
        For i2 = IIf(arr(1, 2) = "", i1 + 1, arr(1, 2)) To IIf(arr(1, 2) = "", 49, arr(1, 2))
        For i3 = IIf(arr(1, 3) = "", i2 + 1, arr(1, 3)) To IIf(arr(1, 3) = "", 49, arr(1, 3))
        For i4 = IIf(arr(1, 4) = "", i3 + 1, arr(1, 4)) To IIf(arr(1, 4) = "", 49, arr(1, 4))
        For i5 = IIf(arr(1, 5) = "", i4 + 1, arr(1, 5)) To IIf(arr(1, 5) = "", 49, arr(1, 5))
        For i6 = IIf(arr(1, 6) = "", i5 + 1, arr(1, 6)) To IIf(arr(1, 6) = "", 49, arr(1, 6))
            If s = i1 + i2 + i3 + i4 + i5 + i6 Then
                y = y + 1
                brr(y, 1) = i1
                brr(y, 2) = i2
                brr(y, 3) = i3
                brr(y, 4) = i4
                brr(y, 5) = i5
                brr(y, 6) = i6
            End If
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
        If y = UBound(brr, 1) Then Exit For
        Next
    End If
    GetArr = brr
End Function
 
Пребольшое Вам спасибо и низкий поклон Вашему таланту.
Теперь всё разрешилось!
Изменено: vikttur - 21.09.2021 00:04:57
 
Цитата
Cristal написал:
Теперь всё разрешилось!
Cristal, проверьте работу макросов у нас с МатросНаЗебре, код выдает разный результат (например, на втором наборе данных или на других наборах)
 
Количество генерируемых комбинаций совпадает! По вертикали 4 столбец есть немного отличия у МатросНаЗебре,  допустим числа на одной вертикали одно под другим собраны рядом у вас эти комбинации в другом месте, самое главное что сгенерируемы все возможные комбинации, Три макроса хороши!
Я взял десятую строку(горизонталь) и сверил все 3 Макроса. У Игоря и МатросНаЗебре,совпадают а у MCH расхождение совпадения по строкам.

Спасибо Вам! Вы просто молодцы! А Вы заметили какие то не совпадения? Если да, покажите на скриншоте!
Изменено: Cristal - 21.09.2021 20:52:16
 
сверьте еще с этим)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
Ігор Гончаренко написал:
сверьте еще с этим)
Я взял десятую строку(горизонталь) и сверил все 3 Макроса. У Игоря и МатросНаЗебре,совпадают а у MCH расхождение совпадения по строкам.
Игорь, Спасибо Вам большое тоже! Все молодцы!
 
Цитата
Cristal написал:
А Вы заметили какие то не совпадения? Если да, покажите на скриншоте!
Второй тест:
Известно 4 числа: 8-12-14-39   Желаемая сумма 111
Какой должен быть результат?
Скрытый текст
Изменено: MCH - 21.09.2021 22:27:03
 
Цитата
MCH написал:
Известно 4 числа: 8-12-14-39   Желаемая сумма 111
Результат будет никакой, потому что после 39 идёт число 40 и тогда не получается желаемая сумма.
Это так должно быть, это хорошо. Идёт отбор комбинаций под желаемую сумму. Если комбинация не вписалась в желаемую сумму она выбрасывается для использования. Из списка сгенерированных комбинаций я их проверяю под мою желаемую сумму, если какая то комбинация не вписалась под желаемую сумму, то она удаляется.
Спасибо!
Изменено: Cristal - 21.09.2021 22:43:15
 
Ну значит я не правильно понял задачу
 
Цитата
MCH написал:
Ну значит я не правильно понял задачу
Уважаемый MCH!!!
Вы Макрос написали хорошо и правильно как Игорь, МатросНаЗебре и Вы!
Количество комбинаций совпадает у всех трёх человек.
У них совпадало построчно, потому что автоматом было отсортировано.
Ваш макрос сгенерировал комбинации потом я вручную сделал сортировку по возрастанию и все макросы совпали по работе.
Спасибо Вам! Приятно с Вами всеми работать!
 
Вот еще один вариант, с другим алгоритмом (получилось похоже на вариант от МатросНаЗебре)
Страницы: 1
Наверх