[已解决]VBA整数删数字后最小数

yorkchenshunan · 发表于 2016-3-30 11:06

这个最佳答案由 yorkchenshunan 给出，感谢 yorkchenshunan 的回答。

单击隐藏图章

本帖最后由 yorkchenshunan 于 2016-3-30 13:39 编辑

按照我的逻辑，先后删除的是3/4/5/6/8，过程如下

Sub jisuan()
Dim ar, n%, m As Single, p%, r%, min1%, min2%, min3%, min%, br, cr, inp$
inp = Application.InputBox("说明：请输整数", "请输入任意整数", , , , , , 2)
If Not IsNumeric(inp) Then
MsgBox "输入有误"
Exit Sub
End If
ReDim ar(1 To Len(inp), 1 To 2) As Integer
For n = 1 To Len(inp)
ar(n, 1) = n
ar(n, 2) = Mid(inp, n, 1)
Next n
Do
m = Application.InputBox("说明：请输入1-" & Len(inp) - 1 & "之间的整数", "请输入删除数字个数", , , , , , 1)
Loop Until Int(m) = m And m >= 1 And m <= 16
min = 1
min3 = 1
ReDim br(1 To Len(inp) - m)
ReDim cr(1 To m)
For p = 1 To Len(inp) - m
min2 = 10
For r = min To p + m
If ar(r, 2) < min2 Then
min1 = ar(r, 1)
min2 = ar(r, 2)
End If
Next r
If min1 > min Then
For r = min To min1 - 1
cr(min3) = ar(r, 2)
min3 = min3 + 1
Next r
End If
min = min1 + 1
br(p) = min2
Next p
If min3 <= m Then
For p = 1 To m + 1 - min3
cr(m + 1 - p) = ar(UBound(ar) - p + 1, 2)
Next p
End If
MsgBox "先后删除数字：" & Join(cr, "，") & Chr(10) & "答案：" & Join(br, "")
End Sub

复制代码

grf1973 · 发表于 2016-3-30 12:03

Sub tt()
Dim L, isfirst As Boolean
x = "13425638694" '原数
jqs = 5 '截取数
msg = "原数：" & x & Chr(10) & "删除个数：" & jqs & Chr(10)
n = Len(x) - jqs '要保留的个数
For k = n To 1 Step -1
If k = n Then isfirst = True Else isfirst = False
L = Len(x) - k + 1
y = getmin(Left(x, L), isfirst)
res = res & y
p = InStr(x, y)
jq = jq & Left(x, p - 1)
x = Mid(x, p + 1)
Next
MsgBox msg & "先后删除数字：" & jq & Chr(10) & "删除后最小：" & res
End Sub
Function getmin(x, isfirst As Boolean) '得到字符串x中的最小数。如果是第一次取值，不含0。
If isfirst Then k = 1 Else k = 0
For i = k To 9
If InStr(x, i) Then Exit For
Next
getmin = i
End Function

复制代码

香川群子 · 发表于 2016-3-30 12:32

这个题目有点意思。

已知m个数字串、需要删除n个数字，余下m-n个数字按原顺序排列得到的数值最小。

我想可以这么做：
1. 取前n+1个数位，找到其中不为零的最小值、如=1、然后剔除这个数之前的所有数字。
2. 继续增加1个数位，找到剩余数中最小值(可以=0)，然后剔除这个数之前的所有数字。
3. 继续步骤2、直到剔除数的个数=n时终止。

vbyou127 · 发表于 2016-3-30 12:41

yorkchenshunan 发表于 2016-3-30 11:06
按照我的逻辑，先后删除的是3/4/5/6/8，过程如下

增加一个条件，删除后的最小数不能以0开头，会不会好难

香川群子 · 发表于 2016-3-30 12:59

算法的代码实现：

Sub test() 'by kagawa
s = InputBox("", "", "80317902254297017652") '输入数字串
m = Len(s) '得到数字串个数m
n = Val(InputBox("n=", "", 9)) '输入需要剔除数字的个数n
ReDim a&(1 To m)
For i = 1 To n + 1 '填写前n+1个数
t = Mid(s, i, 1)
If t = "0" Then a(i) = 10 Else a(i) = t
'如果是0要改为10保护起来不参加首位数挑选【保留数首位不能=0】
Next
For i = n + 2 To m 'n+1以后的数先保护起来不参加挑选
a(i) = 10
Next
t = WorksheetFunction.min(a) '找到n+1中的最小值
j = WorksheetFunctin.Match(t, a, 0) '定位最早出现的这个最小值
For i = 1 To j - 1 '标记剔除数
a(i) = 11: k = k + 1 '标记剔除数、已剔除数统计k+1
Next
For i = j + 1 To n + 1
If a(i) = 10 Then a(i) = 0 '保护的0数值恢复以便参加以后的挑选
Next
a(j) = 10 '第1个保留数标记
r = n + 1 '从n+1位开始
Do While k < n '循环检查直到满足剔除个数k=n
r = r + 1
a(r) = Mid(s, r, 1) '第r位置写入这个数参与挑选
t = WorksheetFunction.min(a) '挑选最小值(可以=0)
j2 = WorksheetFunction.Match(t, a, 0) '最小值定位
For i = j + 1 To j2 - 1
a(i) = 11: k = k + 1 '标记剔除数、已剔除数统计k+1
Next
a(j2) = 10 '标记这个保留数
j = j2 '更新检查位置
Loop
'以上完成、然后输出结果
s1 = s: s2 = s: s3 = ""
For i = 1 To m
If a(i) = 11 Then Mid(s2, i, 1) = "-" Else Mid(s1, i, 1) = "-": s3 = s3 & Mid(s, i, 1)
Next
MsgBox s & vbCr & s1 & vbCr & s2 & vbCr & s3
'显示为原数字串、剔除数、保留数、合并保留数
End Sub

复制代码

例如：

9/20 (20位数字串中剔除9个数)

80317902254297017652
803-79---54-97------
---1--022--2--017652
10222017652

第1个0不能保留。

grf1973 · 发表于 2016-3-30 13:27

我的代码跟香川的思路完全一致。加上注释并改成手动输入。

Sub tt()
Dim L, isfirst As Boolean
x = InputBox("请输入要截取的数字串", "", "80317902254297017652") '输入数字串
jqs = Val(InputBox("请输入的剔除数字的个数", "", 9)) '截取数(需要剔除数字的个数)
msg = "原数：" & x & Chr(10) & "删除个数：" & jqs & Chr(10)
n = Len(x) - jqs '要保留的个数
For k = n To 1 Step -1 '要保留k位数
If k = n Then isfirst = True Else isfirst = False '看看是不是第一位
L = Len(x) - k + 1 '去掉后面k-1位，取前半段
y = getmin(Left(x, L), isfirst) '找到最小值，如果是第一次取值，不含0
res = res & y
p = InStr(x, y) '最小值的位置p
jq = jq & Left(x, p - 1) 'p前各位即为删除的数字
x = Mid(x, p + 1) 'p后各位即为下一次截取的字符串
Next
MsgBox msg & "先后删除数字：" & jq & Chr(10) & "删除后最小：" & res
End Sub
Function getmin(x, isfirst As Boolean) '得到字符串x中的最小数。如果是第一次取值，不含0。
If isfirst Then k = 1 Else k = 0
For i = k To 9
If InStr(x, i) Then Exit For
Next
getmin = i
End Function

复制代码

yorkchenshunan · 发表于 2016-3-30 13:45

vbyou127 发表于 2016-3-30 12:41
增加一个条件，删除后的最小数不能以0开头，会不会好难

简单。

Sub jisuan()
Dim ar, n%, m As Single, p%, r%, min1%, min2%, min3%, min%, br, cr, inp$
inp = Application.InputBox("说明：请输整数", "请输入任意整数", , , , , , 2)
If Not IsNumeric(inp) Then
MsgBox "输入有误"
Exit Sub
End If
ReDim ar(1 To Len(inp), 1 To 2) As Integer
For n = 1 To Len(inp)
ar(n, 1) = n
ar(n, 2) = Mid(inp, n, 1)
Next n
Do
m = Application.InputBox("说明：请输入1-" & Len(inp) - 1 & "之间的整数", "请输入删除数字个数", , , , , , 1)
Loop Until Int(m) = m And m >= 1 And m <= 16
min = 1
min3 = 1
ReDim br(1 To Len(inp) - m)
ReDim cr(1 To m)
For p = 1 To Len(inp) - m
min2 = 10
If p = 1 Then
For r = min To p + m
If ar(r, 2) < min2 And ar(r, 2) > 0 Then
min1 = ar(r, 1)
min2 = ar(r, 2)
End If
Next r
Else
For r = min To p + m
If ar(r, 2) < min2 Then
min1 = ar(r, 1)
min2 = ar(r, 2)
End If
Next r
End If
If min1 > min Then
For r = min To min1 - 1
cr(min3) = ar(r, 2)
min3 = min3 + 1
Next r
End If
min = min1 + 1
br(p) = min2
Next p
If min3 <= m Then
For p = 1 To m + 1 - min3
cr(m + 1 - p) = ar(UBound(ar) - p + 1, 2)
Next p
End If
MsgBox "先后删除数字：" & Join(cr, "，") & Chr(10) & "答案：" & Join(br, "")
End Sub

复制代码

yorkchenshunan · 发表于 2016-3-30 13:48

grf1973 发表于 2016-3-30 13:27
我的代码跟香川的思路完全一致。加上注释并改成手动输入。

你的代码，尾巴处理有问题，如输入12300111789，删除5位，显示不了删除8/9

yorkchenshunan · 发表于 2016-3-30 13:51

香川群子发表于 2016-3-30 12:59
算法的代码实现：例如：

9/20 (20位数字串中剔除9个数)

你的代码我10版的出错，j = WorksheetFunctin.Match(t, a, 0) 一句无法运行

dsmch · 发表于 2016-3-30 13:56

本帖最后由 dsmch 于 2016-3-30 18:15 编辑

Sub Macro1()
x = "80317902254297017652" '文本型数值
n = 11 '结果保留位数
l=n
t = Replace(Mid(x, 1, Len(x) - n + 1), "0", "")
Do Until Len(zf) = l
p = 10
For i = 1 To Len(t)
s = Val(Mid(t, i, 1))
If s < p Then p = s
Next
n = n - 1
zf = zf & p
st = InStr(x, p)
x = Mid(x, st + 1)
t = Mid(x, 1, Len(x) - n + 1)
Loop
MsgBox zf'结果
End Sub

复制代码

		自动登录	找回密码
密码			注册

[已解决]VBA整数删数字后最小数

点评

评分

评分

评分

点评