[已解决]求代码

mmc998

Book三码.rar (21.61 KB, 下载次数: 26)

2015-3-1 20:01 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2015-3-2 10:05

请看附件。

跳转到最佳答案楼层

gdpgdp317

建议楼主带个简单的说明，具体要个什么效果

mmc998

gdpgdp317 发表于 2015-3-1 20:16
建议楼主带个简单的说明，具体要个什么效果

把里面的 公式处理的结果，用vba来处理

mmc998

当a列数据与行2数据相同时,就添0,

grf1973

1. Function Paixu(xstr)       '把任意数据型字符按各位数从小到大排序
   
2.     Dim w(9)
   
3.     For i = 1 To Len(xstr)
   
4.         a = Val(Mid(xstr, i, 1))
   
5.         w(a) = a
   
6.     Next
   
7.     Paixu = "'" & Join(w, "")
   
8. End Function
   
9. 
   
10. Sub tt()
    
11.     r = Cells(Rows.Count, 1).End(xlUp).Row
    
12.     c = Cells(2, Columns.Count).End(xlToLeft).Column
    
13.     arr = [a1].Resize(r, c)
    
14.     Set d = CreateObject("scripting.dictionary")
    
15.     For i = 3 To c     '各列
    
16.         x = Paixu(arr(2, i))        '各数内排序
    
17.         d(x) = d(x) & "," & i      '得出列号，入字典
    
18.         arr(2, i) = "'" & arr(2, i)
    
19.     Next
    
20.     For i = 4 To r       '各行
    
21.         n = 0
    
22.         x = Paixu(arr(i, 1))         '首数内排序
    
23.         arr(i, 1) = "'" & arr(i, 1)
    
24.         If Not d.exists(x) Then         '如果列中没有
    
25.             For j = 3 To c: arr(i, j) = j - 1: Next         '从1开始到末列顺序填
    
26.         Else          '如果第2行某列数与首数相同（排序过后）
    
27.             xrr = Split(d(x), ",")          '找出各列
    
28.             For j = 1 To UBound(xrr)
    
29.                 xc = Val(xrr(j))
    
30.                 arr(i, xc) = "P"        '找出各列并加以标记
    
31.             Next
    
32.             For j = 3 To c          '对于各列
    
33.                 n = n + 1   '顺序+1
    
34.                 If arr(i, j) = "P" Then n = 0          '如果已作标记，则令为0
    
35.                 arr(i, j) = n
    
36.             Next
    
37.         End If
    
38.     Next
    
39.     [a1].Resize(r, c) = arr       '显示结果
    
40. End Sub

复制代码

grf1973

请看附件。

grf1973

那个Function要小改一下，不然如果一个数值内有相同数字会有问题。

1. Function Paixu(xstr)       '把任意数据型字符按各位数从小到大排序
   
2.     Dim w(9)
   
3.     For i = 1 To Len(xstr)
   
4.         a = Val(Mid(xstr, i, 1))
   
5.         w(a) = w(a) & a
   
6.     Next
   
7.     Paixu = "'" & Join(w, "")
   
8. End Function

复制代码

grf1973

主程序也可小改一下。刚才有点重复。

1. Sub tt()
   
2.     r = Cells(Rows.Count, 1).End(xlUp).Row
   
3.     c = Cells(2, Columns.Count).End(xlToLeft).Column
   
4.     arr = [a1].Resize(r, c)
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     For i = 3 To c     '各列
   
7.         x = Paixu(arr(2, i))        '各数内排序
   
8.         d(x) = d(x) & "," & i      '得出列号，入字典
   
9.         arr(2, i) = "'" & arr(2, i)
   
10.     Next
    
11.     For i = 4 To r       '各行
    
12.         n = 0
    
13.         x = Paixu(arr(i, 1))         '首数内排序
    
14.         arr(i, 1) = "'" & arr(i, 1)
    
15.         If d.exists(x) Then          '如果第2行某列数与首数相同（排序过后）
    
16.             xrr = Split(d(x), ",")          '找出各列
    
17.             For j = 1 To UBound(xrr)
    
18.                 xc = Val(xrr(j))
    
19.                 arr(i, xc) = "P"        '找出各列并加以标记
    
20.             Next
    
21.         End If
    
22.         For j = 3 To c          '对于各列
    
23.             n = n + 1   '顺序+1
    
24.             If arr(i, j) = "P" Then n = 0          '如果已作标记，则令为0
    
25.             arr(i, j) = n
    
26.         Next
    
27.     Next
    
28.     [a1].Resize(r, c) = arr       '显示结果
    
29. End Sub
    

复制代码

雪舞子

楼主测试，

1. Dim qh As New swsqh
   
2. Sub test()
   
3.     Dim arr, x%, y%, i%, j%, n%
   
4.     [b3:ark999].Clear
   
5.     arr = Range("a1:ark" & [a65536].End(3).Row)
   
6.     With qh
   
7.         For i = 4 To UBound(arr)
   
8.             .sws = arr(i, 1): x = .he
   
9.             For j = 3 To UBound(arr, 2)
   
10.                 .sws = arr(2, j): y = .he
    
11.                 For n = 1 To 3
    
12.                     If InStr(arr(2, j), Mid(arr(i, 1), n, 1)) = 0 Then Exit For
    
13.                 Next
    
14.                 If n > 3 And x = y Then
    
15.                     arr(i, j) = 0
    
16.                 Else
    
17.                     arr(i, j) = arr(i, j - 1) + 1
    
18.                 End If
    
19.             Next
    
20.             
    
21.         Next
    
22.         
    
23.     End With
    
24.     Union(Columns("A"), Rows(2)).NumberFormatLocal = "@"
    
25.     [a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
26. End Sub

复制代码

原表中公式可能有些问题，当数值类似110，101，011时可能排序不正确。

雪舞子

上述代码用到了类模块

1. Dim xx$
   
2. Property Let sws(x$)
   
3. xx = x
   
4. End Property
   
5. Property Get he()
   
6. Dim i%
   
7. For i = 1 To 3
   
8.     he = he + Val(Mid(xx, i, 1))
   
9. Next
   
10. End Property
    

复制代码

Book三码.rar (34.78 KB, 下载次数: 19)

2015-3-2 10:52 上传

点击文件名下载附件