Разложить на строки (Excel)

aks_sv · 23 фев 2008, 19:57

Помогите решить, пожалуйста, такую задачу.
Имеется строка с различными числами, например: 6; 15; 2; 4; 11; 7; 9; 6; 8. Количество чисел может изменяться. Необходимо разложить по строкам эти числа, причем сумма чисел в этих строках не должна превышать определенного значения, например 20. Естественно, количество этих строк должно быть наименьшим, а сумма в строках максимальной, остаток не в счет.
В приведенном примере (6+15+2+4+11+7+9+6+8) : 20 = 3,4. Строк получается четыре:
15; 4 = 19 < 20
11; 9 = 20
8; 6; 6 = 20
2; 7 = 9 < 20

Aent · 23 фев 2008, 22:28

Что то мне это напоминает учебную задачку по информатике ...
А самому подумать совсем не тянет?

aks_sv · 24 фев 2008, 10:27

Aent писал(а):Что то мне это напоминает учебную задачку по информатике ...
А самому подумать совсем не тянет?

Скорее по комбинаторике...
Я не думаю, что это так просто, если есть варианты - подскажите

Aent · 24 фев 2008, 13:02

классический жадный алгоритм

aks_sv · 24 фев 2008, 13:11

Aent писал(а):классический жадный алгоритм

И как его применить в VBA?

Aent · 24 фев 2008, 20:14

aks_sv, да задачка оказалась несколько сложнее чем мне показалось на первый взгляд. Чистый жадный алгоритм не найдёт решения 8+6+6.
Тем не менее привожу пока код c этим алгоритмом. Подумаю над точным выполнением, сформулированного вами условия. Не хочется делать полный перебор с
отсеченим.

Код: Выделить всё

Public Sub test()
    Dim v As Variant
    v = Array(6, 15, 2, 4, 11, 7, 9, 6, 8)
    SmartPacker v, 20
End Sub
Public Sub SmartPacker(v As Variant, maxval As Integer)
    Dim i As Integer, k As Integer, j As Integer
    Dim iSum As Integer
    Dim t As Variant
    Dim bSwap As Boolean
    Dim sErr As String
    Dim sRow As String
    'проверяем допустимость данных
    sErr = vbNullString
    For i = LBound(v) To UBound(v)
        If v(i) > maxval Then
            sErr = sErr & Str(v(i)) & " "
        End If
    Next i
    
    If Len(sErr) > 0 Then
        MsgBox "Входящий массив содержит слишком большие значения:" & sErr
        Exit Sub
    End If
    'сортируем входящий массив по убыванию
    Do
        bSwap = False
        For i = LBound(v) + 1 To UBound(v)
            If v(i) > v(i - 1) Then
                t = v(i - 1)
                v(i - 1) = v(i)
                v(i) = t
                bSwap = True
            End If
        Next i
    Loop While (bSwap)
   
    k = 0
    ' осуществляем выборку подходящих
    Do
        iSum = 0
        sRow = vbNullString
        For i = LBound(v) To UBound(v)
            If v(i) > 0 Then
                If iSum + v(i) <= maxval Then
                    iSum = iSum + v(i)
                    sRow = sRow & "+" & Str(v(i))
                    v(i) = 0
                    If iSum = maxval Then
                        k = k + 1
                        Debug.Print Format$(k, "00"": """) & Mid$(sRow, 2) & "=" & Str(iSum)
                        iSum = 0
                        Exit For
                    End If
                End If
            End If
        Next i
        If iSum > 0 Then    'группа с недобором
            k = k + 1
            Debug.Print Format$(k, "00"": """) & Mid$(sRow, 2) & "=" & Str(iSum)
            iSum = 0
        ElseIf Len(sRow) = 0 Then
            Exit Do
        End If
    Loop
End Sub

Aent · 24 фев 2008, 22:23

Модифицированный вариант. Cохраняет данные на рабочий лист и находит
пропущенное в прошлом варианте решение

Код: Выделить всё

Public Sub test()
    Dim v As Variant
    v = Array(6, 15, 2, 4, 11, 7, 9, 6, 8)
    SmartPacker v, 20
End Sub
Public Sub SmartPacker(v As Variant, maxval As Integer)
    Dim i As Integer, k As Integer, j As Integer
    Dim iSum As Integer, ii As Integer
    Dim t As Variant
    Dim bSwap As Boolean
    Dim sErr As String
    Dim sRow As String
    'проверяем допустимость данных
    sErr = vbNullString
    For i = LBound(v) To UBound(v)
        If v(i) > maxval Then
            sErr = sErr & Str(v(i)) & " "
        End If
    Next i
    
    If Len(sErr) > 0 Then
        MsgBox "Входящий массив содержит слишком большие значения:" & sErr
        Exit Sub
    End If
    'сортируем входящий массив по убыванию
    Do
        bSwap = False
        For i = LBound(v) + 1 To UBound(v)
            If v(i) > v(i - 1) Then
                t = v(i - 1)
                v(i - 1) = v(i)
                v(i) = t
                bSwap = True
            End If
        Next i
    Loop While (bSwap)
    k = 1
    ' осуществляем выборку подходящих
    Do
        iSum = 0
        j = 2
        sRow = vbNullString
        For i = LBound(v) To UBound(v)
            If v(i) > 0 Then
                If iSum + v(i) <= maxval Then
                    iSum = iSum + v(i)
                    Cells(k, j).Value = v(i)
                    j = j + 1
                    v(i) = 0
                    If iSum = maxval Then
                        Cells(k, 1) = iSum
                        k = k + 1
                        iSum = 0
                        Exit For
                    End If
                End If
            End If
        Next i
        If iSum > 0 Then    'группа с недобором
            Cells(k, 1) = iSum
            k = k + 1
            iSum = 0
        ElseIf j = 2 Then
            Exit Do
        End If
    Loop
    ' возможно нужно подправить наш жадный алгоритм для последних записей
    k = k - 1 'номер последней строки
    If Cells(k, 1) < maxval Then
        iSum = Cells(k, 1) + Cells(k - 1, 2)
        If iSum > Cells(k - 1, 1) And iSum <= maxval Then 'нужна корректировка
            Cells(k - 1, 1) = iSum
            iSum = 0
            j = 3
            Do While Cells(k - 1, j) > 0
                iSum = iSum + Cells(k - 1, j)
                Cells(k + 1, j - 1) = Cells(k - 1, j)
                Cells(k - 1, j).ClearContents
                j = j + 1
            Loop
            Cells(k + 1, 1) = iSum
            iSum = Cells(k - 1, 2)
            j = 3
            Do While Cells(k, j - 1) > 0
                Cells(k - 1, j) = Cells(k, j - 1)
                j = j + 1
            Loop
            Rows(k).Delete
        End If
    End If
End Sub

Свойства и методы объектной модели Excel сознательно использованны минимально для проявления сути алгоритма.

aks_sv · 25 фев 2008, 18:40

Aent, Опробовал, все-супер! Спасибо! Теперь буду разбираться с "жадюкой" в коде.

aks_sv · 26 фев 2008, 19:10

Aent, Я надоел, наверно.
Хочу вместо перечислений значений в коде выдергивать их из диапазона:

Public Sub test()
Dim v As Variant
Dim r As Long, LastRow As Long
LastRow=Range("K65536").End(xlUp).Row
For r = 1 To LastRow
v = Cells(r, 11).Value
Next r
SmartPacker v, 20
End Sub

Не работает, пишет в строке:
For i = LBound(v) To UBound(v)
ошибка?

Pavel55 · 26 фев 2008, 21:55

Лучше заполнять массив не циклом, а вот так

Код: Выделить всё

Sub Макрос1()
Dim iArray As Variant
Dim i As Long
    'для столбца К (т.е. 11 столбец)
    iArray = Application.Transpose(Range(Cells(1, 11), Cells(Cells(Rows.Count, 11).End(xlUp).Row, 11)))
    'iArray = Application.Transpose(Range("K1:K" & Range("K65536").End(xlUp).Row))
    For i = LBound(iArray) To UBound(iArray)
        Debug.Print iArray(i)
    Next
End Sub