寻找最佳数字组合(用VBA或函数公式都可)

jxlhx97601 · 发表于 2013-10-21 19:51

寻找数字的最佳组合:
在C3:H3,C4:H4,C5:H5,C6:H6,C7:H7,C8:H8,……同一行中,
找出哪三个数字同时出现次数最多的,并按次数多少排列在K列,J列显示出现次数.C：H中同时出现的相同数字，假设C3：H3中出现11，26，34如果在C9：H9中也出现了11，26，34就说明这三个数字是最佳组合，数字不分前后的。详情请看附件,请各位高手帮忙,谢谢

Book1.rar (50.59 KB, 下载次数: 62)

jxlhx97601 · 发表于 2013-10-22 20:53

是不是很难啦,没人回复,如果只在200行以内寻找最佳组合不知是不是容易点呢?急盼高手帮忙!!!!!!!!!!

香川群子 · 发表于 2013-10-23 12:36

问题有点难度。函数不可能解决。

帮你写了个VBA代码，用到了数组、字典、排序、组合、递归等知识。

香川群子 · 发表于 2013-10-23 13:39

貌似附件没传上去？再发一次。

香川群子 · 发表于 2013-10-23 13:42

贴一下代码：

Dim sj&(), d, m&, n&
Sub kagawa()
Dim i&, l&, r$
tms = Timer
sj0 = [a2].CurrentRegion: l = Application.Max(sj0)
n = 3: m = UBound(sj0, 2) - 2
Set d = CreateObject("Scripting.Dictionary")
ReDim sj&(1 To m)
For i = 2 To UBound(sj0)
Call px(sj0, sj, i, l) '每一行数据先排序
r = sj0(i, 1) & sj0(i, 2)
Call dgZH(r, "", 0, 1) '然后进行递归组合，组合结果加入字典
Next
p = d.keys
q = d.items
ReDim jg(d.Count - 1, 2)
For i = 0 To d.Count - 1
jg(i, 0) = Val(q(i))
jg(i, 1) = "'" & p(i)
jg(i, 2) = Split(q(i), "|")(1)
Next
'以上为取出字典结果
With [a2].Offset(, m + 3)
.CurrentRegion.Offset(1) = ""
.Resize(d.Count, 3) = jg
.Resize(d.Count, 3).Sort .Offset(0, 0), 2, , , , , , 2
End With
'以上为字典结果写入工作表，并按出现次数倒排序
MsgBox Format(Timer - tms, "0.000s ") & d.Count
End Sub
Function px(sj0, sj&(), i&, l&)
Dim j&, k&, t&
ReDim a&(1 To l)
For j = 3 To m + 2
t = sj0(i, j): a(t) = t
Next
For j = 1 To l
t = a(j): If t Then k = k + 1: sj(k) = t
Next
End Function
Sub dgZH(r$, s$, i&, t&)
Dim j&, s1$, s2$
For j = i + 1 To m - n + t
If t < n Then
Call dgZH(r, s & "-" & sj(j), j, t + 1)
Else
s1 = Mid(s, 2) & "-" & sj(j)
s2 = d(s1)
If s2 = "" Then
d(s1) = 1 & "|" & r
Else
d(s1) = Val(s2) + 1 & "|" & Split(s2, "|")(1) & " " & r
End If
End If
Next
End Sub

复制代码

香川群子 · 发表于 2013-10-23 13:48

本帖最后由香川群子于 2013-10-23 14:15 编辑

排序其实用插入排序更好一些。

过程中调用代码为：
Call px2(sj0, sj, i)

排序代码改为：

Function px2(sj0, sj&(), i&)
Dim j&, k&, t&
sj(1) = sj0(i, 3)
For j = 2 To m
t = sj0(i, j + 2)
For k = j To 2 Step -1
If t < sj(k - 1) Then sj(k) = sj(k - 1) Else Exit For
Next
sj(k) = t
Next
End Function

复制代码

这样计算次数会少一些。

排序时间从 0.3秒缩短为 0.02秒，相差15倍。但整体只改善了0.2秒多……似乎影响不大，呵呵。

yangyangzhifeng · 发表于 2013-10-23 15:06

试试看

Sub test()
Dim ar, i&, j&, br, d, r, n&, a&, b&, c&, st$, zz(1 To 49), tt
tt = Timer
Set d = CreateObject("scripting.dictionary")
a = 3 '要求同时出现几个数字
n = Application.Combin(6, a)
ReDim zb&(1 To n, 1 To a), x&(1 To a), y&(1 To a)
For i = 1 To a
x(i) = i
y(i) = i + 6 - a
Next
For i = 1 To n
For b = 1 To a
zb(i, b) = x(b)
Next
x(a) = x(a) + 1
If x(a) > y(a) Then
For c = a - 1 To 1 Step -1
If x(c) < y(c) Then
j = c
Exit For
End If
Next
End If
If j > 0 Then
x(j) = x(j) + 1
For b = j + 1 To a
x(b) = x(b - 1) + 1
Next
j = 0
End If
Next
ar = Range("a3", Range("i65536").End(3))
ReDim br(1 To n * UBound(ar), 1 To 3)
For i = 1 To UBound(ar)
Erase zz: b = 2
For j = 3 To 8
zz(ar(i, j)) = 1
Next
For j = 1 To UBound(zz)
If zz(j) = 1 Then
b = b + 1
ar(i, b) = j
End If
Next
Next
For i = 1 To UBound(ar)
For j = 1 To n
st = ""
For b = 1 To a
st = st & ar(i, zb(j, b) + 2) & "-"
Next
st = Left(st, Len(st) - 1)
r = d(st)
If r = "" Then
r = d.Count: d(st) = r
br(r, 1) = 1
br(r, 2) = st
br(r, 3) = ar(i, 1) & ar(i, 2)
Else
br(r, 3) = br(r, 3) & "-" & ar(i, 1) & ar(i, 2)
br(r, 1) = br(r, 1) + 1
End If
Next
Next
Application.ScreenUpdating = False
[j2:l65536].ClearContents
[j2].Resize(d.Count, 3) = br
Range("j2:l65536").Sort key1:=[j2], order1:=xlDescending, header:=xlNo
[j12:l65536].ClearContents
Application.ScreenUpdating = False
MsgBox Format(Timer - tt, "0.000s")
End Sub

复制代码

香川群子 · 发表于 2013-10-23 19:41

呵呵，我看错题目了……楼主只要1-6中抽取3个组合，我做了1-7中取3个。

代码重新改一下。

香川群子 · 发表于 2013-10-23 19:54

代码更新，并作了简单注释。

Dim sj$(), jg(), d, m&, n&, k&
Sub kagawa()
Dim i&, l&, r$
tms = Timer
sj0 = [a2].CurrentRegion
n = 3
m = UBound(sj0, 2) - 3
Set d = CreateObject("Scripting.Dictionary") '设置字典便于统计相同组合
ReDim sj$(1 To m) '定义数组存放排序后的本行原始数据
ReDim jg(65534, 2) '定义储存结果的数组jg
k = 0 '字典统计关键词个数初始化
For i = 2 To UBound(sj0)
Call px(sj0, sj, i) '本行数据排序
r = sj0(i, 1) & sj0(i, 2) '本行信息
Call dgZH(r, "", 0, 1) '递归组合，并在组合过程中使用字典
Next
With [a2].Offset(, m + 4)
.CurrentRegion.Offset(1) = ""
.Resize(k, 3) = jg '输出结果到工作表
.Resize(k, 3).Sort .Offset(0, 0), 2, , , , , , 2 '结果按出现次数倒排序
.Resize(k, 3).Offset(15) = "" '仅保留前15个结果（需要增减保留数时改Offset括号里的值即可）
End With
MsgBox Format(Timer - tms, "0.000s ") & k
' Erase jg
End Sub
Function px(sj0, sj$(), i&) '插入排序代码
Dim j&, l&, t$
sj(1) = Right("0" & sj0(i, 3), 2)
For j = 2 To m
t = Right("0" & sj0(i, j + 2), 2)
For l = j To 2 Step -1
If t < sj(l - 1) Then sj(l) = sj(l - 1) Else Exit For
Next
sj(l) = t
Next
End Function
Sub dgZH(r$, s$, i&, t&) '递归组合代码
Dim j&, s1$, s2$
For j = i + 1 To m - n + t
If t < n Then
Call dgZH(r, s & sj(j), j, t + 1) '组合抽取数不足n时继续深层递归
Else
s1 = s & sj(j) '得到本次组合结果
s2 = d(s1) '用字典检查本组合的序号
If s2 = "" Then '如字典为空则新增一行记录，并写入基本信息
k = k + 1: d(s1) = k: jg(k, 0) = 1: jg(k, 1) = Format(s1, "'00-00-00"): jg(k, 2) = "'" & r
Else
'否则如已重复则在结果数组jg中添加相关信息，
'字典查询返回得到的s2内容即为该组合在结果数组中的序号位置
jg(s2, 0) = jg(s2, 0) + 1 '出现次数+1
jg(s2, 2) = jg(s2, 2) & " " & r '行信息合并加入
End If
End If
Next
End Sub

复制代码

我的代码整体还算比较简单易懂的。

jxlhx97601 · 发表于 2013-10-24 20:26

本帖最后由 jxlhx97601 于 2013-10-24 20:28 编辑

谢谢,这个代码真不错.如果想增加寻找结果的组数,(也就是说,原来如果只显示出出现最多的前10位,现在想多显示出前30位或前40位),不知怎样修改代码,另外,想增加一个验证功能,即在A1输入(年份+序号),通过点验证按钮,在C1:I1显示A1所表示的所在行的数字.

Book11.rar (80 KB, 下载次数: 56)

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

[求助] 寻找最佳数字组合(用VBA或函数公式都可)