从列表中选择数字样本...从最高数字开始
Choose sample of numbers from the list...starting with the highest number
我在一列中有一个数字列表(大小不一),我想 select 个数字(来自该列)并将其放在另一列中,但是那些 selected 数字必须是列表中最高的,第二个条件是当 selected 数字的总和大于原始人口的 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
假设您的列表是 B1:B8,总和在 B9。那么:
D1: =MAX($B:$B)
D2: =IF(SUM($D:D1)<($B*0.7),LARGE($B:$B,ROW()),"")
从 D2 向下复制...它会按降序显示数字,直到达到 B9 的 70%...
如果列表的大小不同但总和始终是最大的数字,那么您可以选择使用:
D1: =LARGE($B:$B,2)
D2: =IF(SUM($D: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
我在一列中有一个数字列表(大小不一),我想 select 个数字(来自该列)并将其放在另一列中,但是那些 selected 数字必须是列表中最高的,第二个条件是当 selected 数字的总和大于原始人口的 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
假设您的列表是 B1:B8,总和在 B9。那么:
D1: =MAX($B:$B)
D2: =IF(SUM($D:D1)<($B*0.7),LARGE($B:$B,ROW()),"")
从 D2 向下复制...它会按降序显示数字,直到达到 B9 的 70%...
如果列表的大小不同但总和始终是最大的数字,那么您可以选择使用:
D1: =LARGE($B:$B,2)
D2: =IF(SUM($D: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