Question

我在一列中有一个列表（大小不一）的数字，我想选择数字（来自该列）并将其放在另一列中，但这些选定的数字必须是列表中最高的，第二个条件是当所选数字的总和大于原始总数的70％时，此循环停止。如果我没有正确解释我的问题，那么就是图像。

我的解决方案是创建临时列提取最大数字，将其余数字放在另一列中，提取第二大数字，依此类推，但这似乎并不高效。

如果有人有解决方案，我真的很感激任何帮助。

感谢。

编辑：

@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

修改
因为我心情非常好......只需使用它：

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

从列表中选择数字样本...从最高编号开始

1 个答案: