Option Explicit

Private Const ArrSize As Integer =  15     'размер массива
Private Const NumParts As Integer =  6     'количество частей
Private Const MinValue As Integer =  0     'минимальное значение элемента (>=0)
Private Const MaxValue As Integer =  100   'максимальное значение элемента


Private Sub Command1_Click()

Dim Arr( 1  To ArrSize) As Integer    'основной массив
Dim Parts() As Integer              'карта разреза
Dim BestParts() As Integer
Dim BestDiff As Long, PartSum As Long, MinPartSum As Long, MaxPartSum As Long, ArrSum As Long
Dim i As Integer, j As Integer, k As Integer
ReDim Parts( 1  To NumParts)
ReDim BestParts( 1  To NumParts)


'набиваем массив случайными данными
Randomize
ArrSum =  0 
For i =  1  To ArrSize
  Arr(i) = Fix(Rnd( 1 ) * (MaxValue +  1 ) + MinValue)
  ArrSum = ArrSum + Arr(i)
Next
'инициализируем карту
For i =  2  To NumParts
  Parts(i) =  1 
Next
Parts( 1 ) = ArrSize - NumParts +  1 
BestParts = Parts
BestDiff = ArrSum

Do
  'ищем минимальную и максимальную сумму части
  MinPartSum = ArrSum
  MaxPartSum =  0 
  j =  1 
  For i =  1  To NumParts
    PartSum =  0 
    For j = j To j + Parts(i) -  1 
      PartSum = PartSum + Arr(j)
    Next
    If MinPartSum > PartSum Then MinPartSum = PartSum
    If MaxPartSum < PartSum Then MaxPartSum = PartSum
  Next
  'запоминаем лучшую разницу между минимумом и максимумом
  If BestDiff > MaxPartSum - MinPartSum Then
    BestDiff = MaxPartSum - MinPartSum
    BestParts = Parts
  End If
Loop While NextParts(Parts)

'печать результата
Debug.Print "Массив:"
For i =  1  To ArrSize
  Debug.Print CStr(Arr(i)) + " ";
Next
Debug.Print ""
Debug.Print "Разбивка:"
j =  1 
For i =  1  To NumParts
  For j = j To j + BestParts(i) -  1 
    Debug.Print CStr(Arr(j)) + " ";
  Next
  Debug.Print ""
Next

End Sub

Private Function NextParts(ByRef Parts As Variant) As Boolean
'получаем следующий метод разреза массива

Dim i As Integer, Sum As Long
NextParts = True
Do
  'щелкаем счетчиком
  For i =  1  To NumParts
    Parts(i) = Parts(i) +  1 
    If Parts(i) <= ArrSize Then Exit For
    Parts(i) =  1 
  Next
  'проверяем конец счетчика
  If i > NumParts Then
    NextParts = False
    Exit Function
  End If
  'проверяем, подходящая ли комбинация частей
  Sum =  0 
  For i =  1  To NumParts
    Sum = Sum + Parts(i)
  Next
Loop Until Sum = ArrSize

End Function