[已解决]一个Vba的超级难题求解…恳求大神出手...!

大灰狼1976 · 发表于 2017-5-11 08:44

结果必须顺序是可以的，你的例子里面都是条件？和AB等等，很方便确定顺序，但是实际应用时可能会变成各种各样奇怪的物品，无法从字符串直接确定顺序，必须要做一次排序了。

On_fire · 发表于 2017-5-11 16:06

大灰狼1976 发表于 2017-5-11 08:44
结果必须顺序是可以的，你的例子里面都是条件？和AB等等，很方便确定顺序，但是实际应用时可能会变成各种各 ...

谢谢老师…

考虑到实际用途的需求…要添加一项统计(蓝色区域 ),

请您看看截图…

大灰狼1976 · 发表于 2017-5-18 16:05

Sub aaa()
Dim arr, s$, s1$, i&, j&, k&, d As Object, brr, crr, a&, b&, c&, n&, r&, r1&, mx$, rx&, tmp$
Set d = CreateObject("scripting.dictionary")
arr = Range("a4:g" & [a65536].End(3).Row)
For i = 1 To UBound(arr)
For j = 1 To 3
For k = j To 4
mx = arr(i, j)
If mx > arr(i, k) Then
mx = arr(i, k)
rx = k
End If
Next k
If mx <> arr(i, j) Then
tmp = arr(i, j)
arr(i, j) = arr(i, rx)
arr(i, rx) = tmp
End If
Next j
Next i
n = InputBox("Please input ...")
[j:y].ClearContents
ReDim brr(1 To Application.Combin(4, n) * UBound(arr), 1 To n + 4)
crr = brr
For i = 1 To UBound(arr)
For a = 1 To 5 - n
For b = a + 1 To 6 - n
For c = b + 1 To 7 - n
s = arr(i, a) & arr(i, b) & arr(i, 6) & arr(i, 7)
If n = 3 Then s = s & arr(i, c)
If Not d.exists(s) Then
r = r + 1
d(s) = r
brr(r, 1) = arr(i, a)
brr(r, 2) = arr(i, b)
If n = 3 Then brr(r, 3) = arr(i, c)
brr(r, n + 2) = arr(i, 6)
brr(r, n + 3) = arr(i, 7)
End If
brr(d(s), n + 4) = brr(d(s), n + 4) + 1
If n = 2 Then Exit For
Next c
Next b
Next a
Next i
d.RemoveAll
For i = 1 To r
s = ""
For j = 1 To n
s = s & brr(i, j)
Next j
s1 = s
s = s & brr(i, UBound(brr, 2) - 2) & brr(i, UBound(brr, 2) - 1)
s1 = s1 & brr(i, UBound(brr, 2) - 1) & brr(i, UBound(brr, 2) - 2)
If Not d.exists(s) And Not d.exists(s1) Then
r1 = r1 + 1
d(s) = r1
d(s1) = r1
For j = 1 To UBound(brr, 2) - 1
crr(r1, j) = brr(i, j)
Next j
End If
crr(d(s), UBound(brr, 2)) = crr(d(s), UBound(brr, 2)) + brr(i, UBound(brr, 2))
Next i
[j4].Resize(r, n + 4) = brr
[s4].Resize(r1, n + 4) = crr
End Sub

复制代码

大灰狼1976 · 发表于 2017-5-18 16:14

Sub aaa()
Dim arr, s$, s1$, i&, j&, k&, d As Object, brr, crr, a&, b&, c&, n&, r&, r1&, mx$, rx&, tmp$
Set d = CreateObject("scripting.dictionary")
arr = Range("a4:g" & [a65536].End(3).Row)
For i = 1 To UBound(arr)
For j = 1 To 3
For k = j To 4
mx = arr(i, j)
If mx > arr(i, k) Then
mx = arr(i, k)
rx = k
End If
Next k
If mx <> arr(i, j) Then
tmp = arr(i, j)
arr(i, j) = arr(i, rx)
arr(i, rx) = tmp
End If
Next j
Next i
n = InputBox("Please input ...")
[j:y].ClearContents
For k = 1 To 2
ReDim brr(1 To Application.Combin(4, n) * UBound(arr), 1 To n + 4)
If k = 2 Then
For r1 = 2 To UBound(arr)
If arr(r1, 6) > arr(r1, 7) Then
tmp = arr(r1, 6)
arr(r1, 6) = arr(r1, 7)
arr(r1, 7) = tmp
End If
Next r1
End If
For i = 1 To UBound(arr)
For a = 1 To 5 - n
For b = a + 1 To 6 - n
For c = b + 1 To 7 - n
s = arr(i, a) & arr(i, b) & arr(i, 6) & arr(i, 7)
If n = 3 Then s = s & arr(i, c)
If Not d.exists(s) Then
r = r + 1
d(s) = r
brr(r, 1) = arr(i, a)
brr(r, 2) = arr(i, b)
If n = 3 Then brr(r, 3) = arr(i, c)
brr(r, n + 2) = arr(i, 6)
brr(r, n + 3) = arr(i, 7)
End If
brr(d(s), n + 4) = brr(d(s), n + 4) + 1
If n = 2 Then Exit For
Next c
Next b
Next a
Next i
d.RemoveAll
If k = 1 Then [j4].Resize(r, n + 4) = brr Else [s4].Resize(r, n + 4) = brr
r = 0
Next k
End Sub

复制代码

On_fire · 发表于 2017-5-18 16:43

本帖最后由 On_fire 于 2017-5-27 15:37 编辑

大灰狼1976 发表于 2017-5-18 16:14

非常感谢老师,

您的代码, 会帮助到很多有需要的人…

太好了, 上天可以让我遇到你们几位大好人…

好人一生平安, 祝福你们万事如意!!!

On_fire · 发表于 2017-5-27 15:38

大灰狼1976 发表于 2017-5-18 16:14

老师,

我已找到一个参考, 是香川老师的代码…

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