[已解决]请帮助解决这个复杂的排序问题

yvll

请老师帮助解决这个复杂的排序问题，万分感谢！
排序问题.rar (24.27 KB, 下载次数: 27)

2012-1-7 17:09 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

liuts

2012-1-18 09:15

1. Private Sub CommandButton1_Click()
   
2.     Dim t
   
3.     t = Timer
   
4.     Dim arr, d, brr, crr(), result(0 To 9, 1 To 2), i%, j%, x As Byte, y As Byte, m%, sr$
   
5.     Dim drr(1 To 10000, 0 To 9), arr1(1 To 3) As Integer, w As Byte, wn As Byte, wk As Byte, z As Byte
   
6.     arr = Range("e6").CurrentRegion.Value    '数据源装入数组
   
7.     ReDim crr(1 To UBound(arr) - 2, 1 To 3)
   
8.     brr = Range("k2").CurrentRegion.Value    '判定源装入数组
   
9.     For j = 1 To UBound(arr) - 2
   
10.         sr = "": wk = 0
    
11.         '按指定顺序3个作为一组装入新数组
    
12.         crr(j, 1) = arr(j, 1)
    
13.         crr(j, 2) = arr(j + 1, 1)
    
14.         crr(j, 3) = arr(j + 2, 1)
    
15.         For m = 1 To UBound(brr, 2)
    
16.             Erase arr1
    
17.             For k = 1 To 3
    
18.                 For n = 2 To UBound(brr)
    
19.                     '判断判定源中是否包含源数据
    
20.                     If InStr(1, brr(n, m), crr(j, k)) Then
    
21.                         '存在,累加计数
    
22.                         arr1(n - 1) = arr1(n - 1) + 1
    
23.                         If arr1(n - 1) = 3 Then z = n - 1
    
24.                         Exit For
    
25.                     End If
    
26.                 Next n
    
27.             Next k
    
28.             '判定结果属于何种类型
    
29.             '______________________________________________________________
    
30.             '           3       4       3
    
31.             '  arr1     1       1       1    不提取
    
32.             '  arr1     0       3       0    不提取
    
33.             '  arr1     3       0       0    按另一个3位段提取
    
34.             '  arr1     0       0       3    按另一个3位段提取
    
35.             '  arr1     其他情形,全部按未包含数字段提取
    
36. '规则范围
    
37.             If (arr1(1) = arr1(2) And arr1(1) = arr1(3)) Or arr1(2) = 3 Then
    
38.             ElseIf arr1(1) = 3 Or arr1(3) = 3 Then
    
39.                 If crr(j, 1) = crr(j, 2) And crr(j, 1) = crr(j, 3) Then
    
40.                     sr = sr & brr(IIf(z = 1, 3, 1) + 1, m)
    
41.                 Else
    
42.                     sr = sr & brr(3, m)
    
43.                 End If
    
44.             Else
    
45.                 sr = sr & brr(Application.Match(0, arr1, 0) + 1, m)
    
46.             End If
    
47. '规则范围
    
48.         Next m
    
49.         x = Len(sr)
    
50.         '按0-9排列计数
    
51.         For i = 0 To 9
    
52.             y = Len(Replace(sr, i, ""))
    
53.             If InStr(1, sr, i) = 0 Then
    
54.                 result(i, 1) = i: result(i, 2) = 0
    
55.             Else
    
56.                 result(i, 1) = i: result(i, 2) = x - y
    
57.             End If
    
58.         Next
    
59.         '按频率排序
    
60.         For w = 0 To 9
    
61.             For wn = 0 To 9
    
62.                 If result(wn, 2) = w Then
    
63.                     drr(j, wk) = wn
    
64.                     wk = wk + 1
    
65.                 End If
    
66.             Next
    
67.         Next
    
68.     Next j
    
69.     Range("v:ae").ClearContents    '清空
    
70.     Range("v9").Resize(j, 10) = drr    '返回单元格区域
    
71.     MsgBox Timer - t
    
72. End Sub

复制代码

跳转到最佳答案楼层

香川群子

规则太复杂，令人没兴趣。

是彩民的干活？

yvll

没兴趣你回帖干什么，你看像彩票吗。听口音有点耳熟，好像在哪里听过。

liuts

排序问题.rar (29.75 KB, 下载次数: 22)

2012-1-9 11:22 上传

点击文件名下载附件
规则还是不太清楚，应该有笔误的地方 你先看看结果吧

yvll

liuts 发表于 2012-1-9 11:25
规则还是不太清楚，应该有笔误的地方 你先看看结果吧

liuts 老师，谢谢你的帮助，还是规则比较复杂，我另外写了几个示例，请你看看。排序也有问题，要按从没有出现的数到出现次数最多的数升序排列，出现相同次数的数按从小到大排列。还有E列取3个数，要从上到下3个3个滚动的取，例如123456，取数就是要123、234、345、456这样取。谢谢！
增加说明-排序问题.rar (29.95 KB, 下载次数: 20)

2012-1-12 17:08 上传

点击文件名下载附件

yvll

liuts 发表于 2012-1-9 11:25
规则还是不太清楚，应该有笔误的地方 你先看看结果吧

liuts 版主，请再看看新的解释，谢谢！

liuts

yvll 发表于 2012-1-16 11:09
liuts 版主，请再看看新的解释，谢谢！

排序问题.rar (32.49 KB, 下载次数: 12)

2012-1-16 16:21 上传

点击文件名下载附件

yvll

liuts 发表于 2012-1-16 14:18

谢谢 liuts 版主，引用规则还有两个方面有问题：
1、规则第一大条中的第4条：
E列3个数全在3-4-3的某一个3位数那一段中，则选该列4位数那一段中的全部数。
这一条你是‘选该列3位数的那一段的全部数了’。

2、规则第二大条中的第2条：
E列2个数全在3-4-3的某一个3位数那一段中，则选该列4位数那一段中的全部数。
这一条你也是‘选该列3位数的那一段的全部数了’。

在excel表中做了进一步的解释，请 liuts 版主再帮助改一下。谢谢！
排序问题.rar (32.11 KB, 下载次数: 8)

2012-1-17 14:24 上传

点击文件名下载附件

liuts

1. Private Sub CommandButton1_Click()
   
2.     Dim t
   
3.     t = Timer
   
4.     Dim arr, d, brr, crr(), result(0 To 9, 1 To 2), i%, j%, x As Byte, y As Byte, m%, sr$
   
5.     Dim drr(1 To 10000, 0 To 9), arr1(1 To 3) As Integer, w As Byte, wn As Byte, wk As Byte, z As Byte
   
6.     arr = Range("e6").CurrentRegion.Value    '数据源装入数组
   
7.     ReDim crr(1 To UBound(arr) - 2, 1 To 3)
   
8.     brr = Range("k2").CurrentRegion.Value    '判定源装入数组
   
9.     For j = 1 To UBound(arr) - 2
   
10.         sr = "": wk = 0
    
11.         '按指定顺序3个作为一组装入新数组
    
12.         crr(j, 1) = arr(j, 1)
    
13.         crr(j, 2) = arr(j + 1, 1)
    
14.         crr(j, 3) = arr(j + 2, 1)
    
15.         For m = 1 To UBound(brr, 2)
    
16.             Erase arr1
    
17.             For k = 1 To 3
    
18.                 For n = 2 To UBound(brr)
    
19.                     '判断判定源中是否包含源数据
    
20.                     If InStr(1, brr(n, m), crr(j, k)) Then
    
21.                         '存在,累加计数
    
22.                         arr1(n - 1) = arr1(n - 1) + 1
    
23.                         If arr1(n - 1) = 3 Then z = n - 1
    
24.                         Exit For
    
25.                     End If
    
26.                 Next n
    
27.             Next k
    
28.             '判定结果属于何种类型
    
29.             '______________________________________________________________
    
30.             '           3       4       3
    
31.             '  arr1     1       1       1    不提取
    
32.             '  arr1     0       3       0    不提取
    
33.             '  arr1     3       0       0    按另一个3位段提取
    
34.             '  arr1     0       0       3    按另一个3位段提取
    
35.             '  arr1     其他情形,全部按未包含数字段提取
    
36. '规则范围
    
37.             If (arr1(1) = arr1(2) And arr1(1) = arr1(3)) Or arr1(2) = 3 Then
    
38.             ElseIf arr1(1) = 3 Or arr1(3) = 3 Then
    
39.                 If crr(j, 1) = crr(j, 2) And crr(j, 1) = crr(j, 3) Then
    
40.                     sr = sr & brr(IIf(z = 1, 3, 1) + 1, m)
    
41.                 Else
    
42.                     sr = sr & brr(3, m)
    
43.                 End If
    
44.             Else
    
45.                 sr = sr & brr(Application.Match(0, arr1, 0) + 1, m)
    
46.             End If
    
47. '规则范围
    
48.         Next m
    
49.         x = Len(sr)
    
50.         '按0-9排列计数
    
51.         For i = 0 To 9
    
52.             y = Len(Replace(sr, i, ""))
    
53.             If InStr(1, sr, i) = 0 Then
    
54.                 result(i, 1) = i: result(i, 2) = 0
    
55.             Else
    
56.                 result(i, 1) = i: result(i, 2) = x - y
    
57.             End If
    
58.         Next
    
59.         '按频率排序
    
60.         For w = 0 To 9
    
61.             For wn = 0 To 9
    
62.                 If result(wn, 2) = w Then
    
63.                     drr(j, wk) = wn
    
64.                     wk = wk + 1
    
65.                 End If
    
66.             Next
    
67.         Next
    
68.     Next j
    
69.     Range("v:ae").ClearContents    '清空
    
70.     Range("v9").Resize(j, 10) = drr    '返回单元格区域
    
71.     MsgBox Timer - t
    
72. End Sub

复制代码

yvll

liuts 发表于 2012-1-18 09:15

万分感谢 liuts 版主，非常正确，非常好，再次感谢你！