Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Подбор к комбинации из шести чисел неизвестных слагаеммых(от 1 до 49) к желаемой сумме слагаеммых
 
#1
16.09.2021 20:26:41
Здравствуйте Уважаемые Форумчане!                                
                                           
   Нужна Ваша помощь! Помогите пожалуйста, если это возможно!                                        
   Нужно сделать Подбор к комбинации из 6 чисел неизвестных слагаемых(от 1 до 49) к желаемой сумме                                        
   в случае, если известны в комбинации из 6 чисел только 3 или 4 или 5 чисел.                                        
   Нужно использовать все возможные слагаемые(от 1 до 49), чтобы получить желаемую сумму.                                        
   Ну а если не найдутся не известные слагаемые к желаемой сумме, то тогда буду  к комбинации из 6 чисел                                        
   с известными слагаемыми(3 или 4 или 5 числами) выбирать другую желаемую сумму.                                        
                                           
   Известные слагаемые в комбинации из 6 чисел при этом не меняются.                                        
   У меня Эксцель-2007!                                        
   Нужен Эксцель-макрос и кнопка в верхнем правом углу.                                        
   Спасибо Вам большое! Постарался пошагово объяснить!
Всё остальное в файле-примере Эксцель!
Изменено: vikttur - 16.09.2021 20:44:39
 
 
 
#2
16.09.2021 20:32:03
Цитата
Cristal написал:
Эксцель
кровь из глаз идёт, когда вы программу Excel (в русском произношении "Эксел(ь)", в английском "Иксел" ([ɪkˈsel])) называете "Эксцель"
Изменено: New - 16.09.2021 20:33:18
 
 
 
#3
16.09.2021 21:16:19
New,  8-0  
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#4
16.09.2021 21:25:44
Цитата
New написал:
Иксел" ([ɪkˈsel]))
Спасибо за подмеченную неправильность! Будем учить английский!
 
 
 
#5
16.09.2021 22:54:48
Mershik, не, а что он обижает нашу любимую программу ))  Cristal, это шутка, не обижайтесь, пожалуйста.
Изменено: New - 16.09.2021 22:55:09
 
 
 
#6
17.09.2021 10:03:56
Цитата
New: кровь из глаз идёт, когда вы программу Excel (в русском произношении "Эксел(ь)", в английском "Иксел" ([ɪkˈsel])) называете "Эксцель"
если про кровь именно из ГЛАЗ, то лично меня "иксэл" ранит куда больше, чем "Эксцэль", в котором, по сути одна буква только лишняя
В фонетическом же смысле эта "ц" вообще игнорируется и в итоге слово звучит вполне себе нормально  :)
Изменено: Jack Famous - 17.09.2021 10:04:25
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#7
17.09.2021 10:18:00
Код
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
 
 
 
#8
17.09.2021 10:26:24
Cristal
посмотрел твою задумку, мне кажется тут очень сложно "взломать" таким способом лотерею,
вот из твоего примера Известно 3 числа: 1-2-10    Желаемая сумма 123
Нужно найти все комбинации с неизвестными числами под сумму 123
получается у тебя тут получается сумма всего 13, тебе нужно найти любые три числа от 1 до 49 чтобы в сумме получилось 120, плюс не совсем понятно может ли одно число повторятся дважды?
 
 
 
#9
17.09.2021 10:50:31
Цитата
DJMC: Известно 3 числа: 1-2-10    Желаемая сумма 123… у тебя сумма всего 13, нужно найти любые три числа от 1 до 49 чтобы в сумме получилось 120
просто удивительно, как у вас НЕ получается не только СВОИ вопросы объяснить, но чужие ПОНЯТНЫЕ — ЗАПУТАТЬ  :D
Изменено: Jack Famous - 17.09.2021 10:54:34
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#10
17.09.2021 11:04:46
Цитата
DJMC написал:
тут очень сложно "взломать" таким способом лотерею
взломать лотерею, в которой каждый следующий розыгрыш является СЛУЧАЙНЫМ и НИКАК НЕ ЗАВИСИТ ОТ ВСЕХ ПРЕДЫДУЩИХ - не возможно
спросите у любого что хоть самую малость понимает в азах математики
понимаете? вероятность того что в след. розыгрыше выпадет 1,2,3,4,5,6 точно такая же как вероятность выпасти ЛЮБЫМ другим 6 числам, ЛЮБЫМ! даже тем 6-и, что выпали в прошлом розыгрыше, потому что этот от прошлого НИКАК не зависит
удачи вам!
Изменено: Ігор Гончаренко - 17.09.2021 11:16:11
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#11
17.09.2021 11:19:16
Цитата
Jack Famous написал:
как у вас НЕ получается не только СВОИ вопросы объяснить, но чужие
вопрос нужно задать так чтобы никто не смог угадать систему выигрыша
а то угадают и понабегут выигрывать вместо DJMC,
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#12
17.09.2021 15:57:48
Спасибо Вам большое МатросНаЗебре!!
Попробовал я этот код выдаёт ошибку!
В разных местах листа я размещал комбинации, выдаёт ошибку одну и тожу!
Могли бы Вы выставить Макрос Excel-файл с примерами, хотелось бы глянуть как у Вас работает!
Гляньте на код с ошибкой на картинке!
Спасибо за код и за то, что не прошли мимо и не остались равнодушными
Изменено: vikttur - 21.09.2021 09:07:20
 
 
 
#13
17.09.2021 16:15:33
В A1 напишите 123
В B1:D1
1210
Результат выведет во вторую строку и ниже.
 
 
 
#14
17.09.2021 16:51:37
Вот это да! Настоящее чудо произошло! Радости у меня как у ребёнка!
С такими как Вы не страшно в бой идти! При моей удаче в игре, я Вас не забуду! Обязательно Вас я отблагадарю финансово. А я надеюсь на успех и удачу!
Кроме всего прочего Вам преогромное спасибо! Оставайтесь здоровыми и успешными!
Нет слов от успеха!  
 
 
 
#15
17.09.2021 18:32:59
МатросНаЗебре, я прошу прощения, если я Вас отвлекаю от дел!
Можно ли как то это исправить?
Генерируется какая то комбинация например 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
 
 
 
#16
20.09.2021 09:24:30
У меня получилось такое решение, исключающее повторы, работает достаточно быстро
Изменено: MCH - 20.09.2021 09:30:47
 
 
 
#17
20.09.2021 09:46:28
#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
 
 
 
#18
20.09.2021 22:08:49
Пребольшое Вам спасибо и низкий поклон Вашему таланту.
Теперь всё разрешилось!
Изменено: vikttur - 21.09.2021 00:04:57
 
 
 
#19
21.09.2021 06:23:50
Цитата
Cristal написал:
Теперь всё разрешилось!
Cristal, проверьте работу макросов у нас с МатросНаЗебре, код выдает разный результат (например, на втором наборе данных или на других наборах)
 
 
 
#20
21.09.2021 18:58:11
Количество генерируемых комбинаций совпадает! По вертикали 4 столбец есть немного отличия у МатросНаЗебре,  допустим числа на одной вертикали одно под другим собраны рядом у вас эти комбинации в другом месте, самое главное что сгенерируемы все возможные комбинации, Три макроса хороши!
Я взял десятую строку(горизонталь) и сверил все 3 Макроса. У Игоря и МатросНаЗебре,совпадают а у MCH расхождение совпадения по строкам.

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