リストから数字のサンプルを選んでください...最高の番号から始めて

Question

私は1つの列に数字のリスト（サイズが異なります）を持っています。その列から数字を選択して別の列に入れたいと思います。それらの選択された数はリストから最高でなければならず、選択された数の合計が元の母集団の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からコピーB9の70％に到達するまで...それは大きい順に番号が表示されます...

リストのサイズは異なりますが、合計は常にある場合あなたが代わりに使用できる最大の数字：

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