Выберите выборку из списка ... начиная с наибольшего числа

Question

У меня есть список (размер варьируется) чисел в одном столбце, я хотел бы выбрать числа (из этого столбца) и поместить их в другой столбец, но эти выбранные числа должны быть самыми высокими из списка, а второе условие - этот цикл прекращается, когда сумма выбранных чисел превышает 70% от первоначальной совокупности. Если я не правильно объясняю свою проблему, вот изображение.

Мое решение было бы создать временную колонку извлечь наибольшее количество, положить остальную часть этих чисел в другой колонке, извлечь второй по величине, и так далее, но это не кажется эффективным.

Если у кого-то есть решение, я был бы очень признателен за любую помощь.

Спасибо.

EDIT:

@DougGlancy Это то, что я пытался избежать (проверьте ниже). Я знаю, что код ниже может быть более эффективным, но в целом он медленный, особенно когда я запускаю его 10-15 раз подряд, чтобы создать еще один образец данных. Вот почему я ответил вам об эффективности, потому что каждый раз, когда я использую вспомогательные столбцы в VBA, я получаю медленные результаты, поэтому я предположил, что выполнение всего этого в памяти сэкономит некоторое время при выполнении кода.

Я надеюсь, что вы не дали мне отрицательного голоса только из-за этого.

Sub Sample20() 

Worksheets("Junk2").Range("AA:AD").ClearContents 

Dim Mat As Range 
Set Mat = Sheets("Mat").Range("E38") 
Dim Kto As String 
Kto = "20" 
Dim Saldo20 As Long 
Saldo20 = WorksheetFunction.Sum(Sheets("BB").Range("D101:D106")) 

Dim WSS As Worksheet 
Set WSS = Sheets("AN") 
Dim WSD As Worksheet 
Set WSD = Sheets("Junk2") 
Set rRng = WSS.Range("B2:B5000") 

Dim col As String 
col = "AA" 

Dim LastRow As Long 
LastRow = WSD.Range(col & Rows.Count).End(xlUp).Row + 1 

If Saldo20 > Mat.Value * 0.7 Then 
For Each rCell In rRng.Cells 
    If rCell.Value <> "" Then 
    If Left(rCell.Value, 2) = Kto Then 
    If Left(rCell.Value, 3) = "209" Or Left(rCell.Value, 3) = "206" Then 
    GoTo XX 
    Else 
    If rCell.Offset(0, 5).Value > 0 Then 
     WSD.Range(col & LastRow).Value = rCell.Offset(0, 0).Value 
     WSD.Range(col & LastRow).Offset(0, 1).Value = rCell.Offset(0, 1).Value 
     WSD.Range(col & LastRow).Offset(0, 2).Value = rCell.Offset(0, 2).Value/1000 
     WSD.Range(col & LastRow).Offset(0, 3).Value = rCell.Offset(0, 5).Value/1000 
     LastRow = LastRow + 1 
       End If 
       End If 
       End If 
     End If 
XX: 
    Next rCell 
End If 

Worksheets("Junk2").Sort.SortFields.Clear 
    Worksheets("Junk2").Sort.SortFields.Add Key:=Range("AD1:AD2500") _ 
     , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal 
    With Worksheets("Junk2").Sort 
     .SetRange Range("AA1:AD2500") 
     .Header = xlGuess 
     .MatchCase = False 
     .Orientation = xlTopToBottom 
     .SortMethod = xlPinYin 
     .Apply 
    End With 

Dim rCell1 As Range 
Dim rRng1 As Range 
Dim LastR As Integer 
LastR = Sheets("Junk2").Range("AD" & Rows.Count).End(xlUp).Row 
Dim LastR2 As Integer 
LastR2 = Sheets("Junk2").Range("F" & Rows.Count).End(xlUp).Row 

Set rRng1 = Worksheets("Junk2").Range("AD1:AD" & LastR) 

Dim LastRow2 As Long 
LastRow2 = Worksheets("Junk2").Range("AD" & Rows.Count).End(xlUp).Row + 1 

Dim x As Integer 
x = 1 

sum1 = WorksheetFunction.Sum(Worksheets("Junk2").Range("AD1:AD" & LastR)) * 0.7 
Dim Sum2 As Long 
Sum2 = 0 

For Each rCell1 In rRng1.Cells 
If Sum2 > sum1 Then 
Exit Sub 
Else 
     Worksheets("Junk2").Range("F" & LastR2).Value = rCell1.Offset(0, -3).Value 
     Worksheets("Junk2").Range("G" & LastR2).Value = rCell1.Offset(0, -2).Value 
     Worksheets("Junk2").Range("H" & LastR2).Value = rCell1.Offset(0, -1).Value 
     Worksheets("Junk2").Range("I" & LastR2).Value = rCell1.Offset(0, 0).Value 
     LastR2 = LastR2 + 1 
     Sum2 = WorksheetFunction.Sum(Worksheets("Junk2").Range("I1:I" & LastR)) 
     End If 
Next rCell1 

End Sub 

Answer 1

Предположим, что ваш список B1: B8, а сумма находится в B9. Тогда:

D1: =MAX($B$1:$B$8) 
D2: =IF(SUM($D$1:D1)<($B$9*0.7),LARGE($B$1:$B$8,ROW()),"") 

Копирование вниз от D2 ... он покажет цифры в убывающем порядке до 70% от B9 пока не будет достигнуто ...

Если список отличается по размеру, но сумма всегда самое большое количество, которое вы можете использовать в качестве альтернативы:

D1: =LARGE($B:$B,2) 
D2: =IF(SUM($D$1:D1)<(MAX($B:$B)*0.7),LARGE($B:$B,ROW()+1),"") 

И снова копия D2 вниз.

Нет необходимости VBA: P

EDIT
Потому что я нахожусь в очень хорошем настроении ... просто использовать это:

Public Function getUpperValues(xNumbers As Variant, xMax As Double) As Variant 
    Dim i As Long, xArr() As Variant 
    ReDim xArr(1 To Application.Count(xNumbers)) 
    For i = 1 To UBound(xArr) 
    xArr(i) = Application.Large(xNumbers, i) 
    If Application.Sum(xArr) >= xMax Then Exit For 
    Next 
    ReDim Preserve xArr(1 To i) 
    getUpperValues = xArr 
End Function