Sub jjj() Dim a() Set nums_start = [A3] Set nums_end = nums_start.End(xlDown) Set cl_out = nums_start.Offset(, 2) a = Range(nums_start, nums_end) trgt_sum = --[B2].Value i_start = LBound(a) i_end = UBound(a) cur_sum = 0 For i = i_end To i_start Step -1 If cur_sum + a(i, 1) < trgt_sum Then cur_sum = cur_sum + a(i, 1) Else Exit For End If Next i i_start_to = i Application.ScreenUpdating = False Do While (i_start <= i_start_to) And (i_start < i_end) cur_sum = IIf(trgt_sum >= a(i_start, 1), a(i_start, 1), 0) slag = "=" & IIf(trgt_sum >= a(i_start, 1), a(i_start, 1), "") For i = i_start + 1 To i_end If trgt_sum >= (cur_sum + a(i, 1)) Then cur_sum = cur_sum + a(i, 1) slag = slag & IIf(Len(slag) > 1, "+", "") & a(i, 1) End If Next i cl_out.Offset(i_start - 1).Formula = Replace(slag, ",", ".") i_start = i_start + 1 Loop Application.ScreenUpdating = True End Sub
[/vba]
Макрос не ахти какой - как сумел.
[vba]
Код
Sub jjj() Dim a() Set nums_start = [A3] Set nums_end = nums_start.End(xlDown) Set cl_out = nums_start.Offset(, 2) a = Range(nums_start, nums_end) trgt_sum = --[B2].Value i_start = LBound(a) i_end = UBound(a) cur_sum = 0 For i = i_end To i_start Step -1 If cur_sum + a(i, 1) < trgt_sum Then cur_sum = cur_sum + a(i, 1) Else Exit For End If Next i i_start_to = i Application.ScreenUpdating = False Do While (i_start <= i_start_to) And (i_start < i_end) cur_sum = IIf(trgt_sum >= a(i_start, 1), a(i_start, 1), 0) slag = "=" & IIf(trgt_sum >= a(i_start, 1), a(i_start, 1), "") For i = i_start + 1 To i_end If trgt_sum >= (cur_sum + a(i, 1)) Then cur_sum = cur_sum + a(i, 1) slag = slag & IIf(Len(slag) > 1, "+", "") & a(i, 1) End If Next i cl_out.Offset(i_start - 1).Formula = Replace(slag, ",", ".") i_start = i_start + 1 Loop Application.ScreenUpdating = True End Sub