Алгоритм поиска всех комбинаций чисел дающих заданную сумму (на VBA)

7 апреля 2013, VBA, Konstantin

Задача: Есть набор целых чисел (числа не повторяются)

1	3	5	7	8	9	11	2	25	30

Необходимо в Excel написать макрос, который выводит на лист «Результат» все комбинации чисел из набора, дающие в сумме 40. Каждое число можно использовать один раз. Полный перебор комбинаций нежелателен.

Дано: Книга Excel, сотоящая из двух листов. На первом листе (sh1) во второй строке располагается набор целых чисел, а в четвертой строке – необходимая сумма. На втором листе (sh2) будут хранится временные массивы и итоговый результат.

Решение: нижеследующий код из двух процедур находит нужные комбинации не прибегая к полному перебору:

Private Sub Main()
sh2.Cells.ClearContents
lastCol = sh1.Cells(2, sh1.Columns.Count).End(xlToLeft).Column
sSum = sh1.Cells(4, 1).Value '"Сумма для подбора"
'"Временный массив исходных чисел". Заполняем нулями
sh2.Range(sh2.Cells(1, 1), sh2.Cells(1, sSum)).Value = Evaluate("=0")
'"Временный массив с решением". Заполняем нулями
sh2.Range(sh2.Cells(2, 1), sh2.Cells(2, sSum)).Value = Evaluate("=0")
For i = 1 To lastCol 'Заполнение массива исходных чисел
    nNum = sh1.Cells(2, i).Value
    If nNum <= sSum Then
        '"Временный массив исходных чисел".
        'Количество элементов равно значению Суммы для подбора
        'На места, номера которых соответствуют значениям
        'из набора чисел для суммирования, ставятся единицы
        sh2.Cells(1, nNum) = 1
    End If
Next i
sh2.Cells(3, 1).Value = "Результат:"
Call PoiskComb(sSum, sSum) 'Поиск решений
sh2.Rows("1:1").Delete Shift:=xlUp
sh2.Rows("1:1").Delete Shift:=xlUp
sh2.Activate
sh2.Range("A1").Select
End Sub
'Поиск комбинаций чисел из "Временног массива решений"
'(максимальное не больше Ni), дающих в сумме N
Sub PoiskComb(N, Ni)
For i = Ni To 1 Step -1
    If sh2.Cells(1, i) = 1 Then
        N1 = N - i
        If N1 = 0 Then
            'Запись подходящей комбинации
            '---
            'Поиск послденей строки на листе с Результатом
            k = sh2.Cells(sh2.Rows.Count, 2).End(xlUp).Row + 1
            'Добавляем последнее число из комбинации
            'во "Временный массив с решением"
            sh2.Cells(2, i) = 1
            lastColSol = sh2.Cells(2, sh2.Columns.Count).End(xlToLeft).Column
            For j = 1 To lastColSol 'Запись очередного решения
                If sh2.Cells(2, j) = 1 Then
                    lastColI = sh2.Cells(k, sh2.Columns.Count). _
                        End(xlToLeft).Column
                    sh2.Cells(k, lastColI + 1) = j
                End If
            Next j
            'Убираем последнее число из комбинации
            'из "Временного массива с решением" для поиска других
            'возможных решений
            sh2.Cells(2, i) = 0
        ElseIf N1 > 0 Then
            'Если сумма выбранных чисел всё ещё меньше,
            'чем "Сумма для подбора", то ищем числа, в сумме
            'дающие недостающий остаток
            '---
            'Добавляем во "Временный массив с решением" последнее выбранное
            'число и убираем его из "Временного массива исходных чисел"
            sh2.Cells(2, i) = 1
            sh2.Cells(1, i) = 0
            Call PoiskComb(N1, i)
            'Возвращаем это же число во "Временный массив исходных чисел"
            'и удаляем его из "Временного массива с решением"
            sh2.Cells(2, i) = 0
            sh2.Cells(1, i) = 1
        End If
    End If
Next i
End Sub

Итог: на выходе алгоритма имеем следующие комбинации на листе «Результат» (каждая строка – новая комбинация):

1	9	30			
2	8	30			
3	7	30			
1	2	7	30		
2	3	5	30		
1	3	11	25		
1	5	9	25		
1	2	3	9	25	
7	8	25			
2	5	8	25		
3	5	7	25		
1	2	5	7	25	
5	7	8	9	11	
2	3	7	8	9	11
Теги: • •
 
Распечатать Распечатать

2 комментария в “Алгоритм поиска всех комбинаций чисел дающих заданную сумму (на VBA)”

  1. alla-stervo4ka:
    19 декабря 2016 в 5:07

    Задача состоит в следующем, дано любое целое неотрицательное число, найти все комбинации из 2,3,4.

    Ответить

Комментировать

 


На Верх