'本代码只适用正整数，自己改一下吧Option ExplicitDim Target&, best&
'目标值,接近目标值Dim x&(), y&(), z&()
'原始数据,数据标记,提取数据和Dim iCount&, Neg&, Total& '数据个数,负数据和,正数据和Dim lRange&, rRange&
'最小数据,最大数据Dim i&, j&, M&, S&, F&, K&Dim a$(), Result$
'处理数据,处理结果'生成数据Private Sub Command1_Click()RandomizeText4 = ""On Error GoTo err_handleTarget = Text1iCount = Text2a = Split(Text3, ",")If Val(a(0)) > Val(a(1)) Then j = a(1): a(1) = a(0): a(0) = jlRange = a(0)rRange = a(1)Text3 = Join(a, ",")ReDim a(1 To iCount)For j = 1 To iCount
a(j) = Int(Rnd * (rRange - lRange + 1)) + lRangeNextText4 = Join(a)Exit Suberr_handle:MsgBox "数据说明错误", vbApplicationModalEnd SubPrivate Sub Command2_Click()Text5 = ""DoEventsIf Total > Target And Target - rRange > Total - Target Then
Target = Total - Target
SelectDataElse
CullDataEnd IfEnd Sub'提取数据Sub CullData()If Total = Target Then
Text5 = "接近值" & lRange & ":" & vbCrLf & lRange
Exit SubEnd IfFilterDataResult = "最接近值" & j & ":" & vbCrLfReDim a(iCount - 1)Do
a(K) = CStr(x(y(best)))
If j - x(y(best)) Then
j = j - x(y(j))
best = j
K = K + 1
Else
Result = Result & "提取" & K + 1 & "个数:" & vbCrLf
Text5 = Result & Trim(Join(a))
Exit Sub
End IfLoopEnd Sub'选择数据(反向提取数据)Sub SelectData()FilterDataResult = "最接近值" & Total - j & ":" & vbCrLfDo
a(y(best) - 1) = " "
'要去掉的数据用一个空格表示
If j - x(y(best)) Then
j = j - x(y(j))
best = j
K = K + 1
Else
Result = Result & "提取" & iCount - K - 1 & "个数:" & vbCrLf
Text5 = Result & Trim(Replace(Join(a), "", ""))
Exit Sub
End IfLoopEnd Sub'筛选数据Sub FilterData()'按目标值做筛选标记ReDim y(lRange To Target + 1)ReDim z(1 To Target + 1 - lRange)M = Target + rRange \ 2i = 1K = 0Do While iTarget Then
If x(i)Target Then
If S x(y(j))If j = M Then best = Target + 1K = 0End Sub'检查数据Sub GetData(x() As Long, iniData As String)a = Split(iniData)iCount = UBound(a) + 1Neg = 0: Total = 0lRange = a(0): rRange = a(0)ReDim x(1 To iCount)For j = 1 To iCount
x(j) = CLng(Val(a(j - 1)))
If x(j) > 0 Then Total = Total + x(j) Else Neg = Neg + x(j)
If lRange > x(j) Then lRange = x(j)
If rRange-1 And Target > -1 Then
Command2.Enabled = TrueElse
MsgBox "数据错误", vbExclamation, "数据检查"End IfLabel5 = TotalLabel7 = Total - TargetEnd SubPrivate Sub Text1_Change()Text4_ChangeEnd SubPrivate Sub Text2_Change()Text4_ChangeEnd SubPrivate Sub Text3_Change()Text4_ChangeEnd SubPrivate Sub Text4_Change()Label5 = ""Label7 = ""Text5 = ""Command2.Enabled = FalseEnd Sub |
