根据A列的关键字把B列排序

Nsp=娜！再来#

根据A列的关键字把B列排序，谢谢！


根据A列的关键字把B列排序.zip (18.6 KB, 下载次数: 22)

2018-8-5 18:25 上传

点击文件名下载附件

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, t
  arr = [a1].CurrentRegion
  For i = 2 To UBound(arr, 1)
    For j = 2 To UBound(arr, 1)
      If InStr(arr(i, 2), arr(j, 1)) Then arr(i, 3) = j - 1: Exit For
    Next
    If j = UBound(arr, 1) + 1 Then MsgBox "!": Exit For
  Next
  For i = 2 To UBound(arr, 1) - 1
    For j = i + 1 To UBound(arr, 1)
      If arr(i, 3) > arr(j, 3) Then
        t = arr(i, 2): arr(i, 2) = arr(j, 2): arr(j, 2) = t
        t = arr(i, 3): arr(i, 3) = arr(j, 3): arr(j, 3) = t
      End If
  Next j, i
  For i = 1 To UBound(arr, 1): arr(i, 1) = arr(i, 2): Next
  With [i1]
    .Resize(Rows.Count).ClearContents
    .Resize(UBound(arr, 1)) = arr
  End With
End Sub

duquancai

1. Sub main()
   
2.     Dim arr, j$, r&, i&, s$
   
3.     r = Cells(Rows.Count, 1).End(3).Row: arr = Range("a1:c" & r)
   
4.     For i = 2 To r: s = s & "," & arr(i, 1): Next
   
5.     j = "o={},i=0,r=/''/;'" & s & "'.replace(/[^,]+/g,function(s){o[s]=i++;});for(k in o)r+='|'+k;"
   
6.     j = j & "function f(k){return o.hasOwnProperty(k)?o[k]:i;};"
   
7.     j = j & "function q(x,y){return f((m=x[0].match(r))?m[0]:'')-f((n=y[0].match(r))?n[0]:'');};"
   
8.     Call mySort(arr, j, 2, 2, r, 3)
   
9.     Range("e1").Resize(r, 3) = arr
   
10.     MsgBox "ok!"
    
11. End Sub
    
12. Sub mySort(ByRef a, ByVal p$, ByVal l1&, ByVal l2&, ByVal u1&, ByVal u2&)
    
13.     Dim js As Object, i&, j&, s$, sr$
    
14.     Set js = CreateObject("MSScriptControl.ScriptControl")
    
15.     js.Language = "JavaScript"
    
16.     For i = l1 To u1
    
17.         For j = l2 To u2
    
18.             s = s & "," & "'" & a(i, j) & "'"
    
19.         Next
    
20.         sr = sr & "," & "[" & Mid(s, 2) & "]": s = Empty
    
21.     Next
    
22.     js.AddCode "a=" & "[" & Mid(sr, 2) & "]" & ";" & p & "a.sort(q);"
    
23.     For i = l1 To u1
    
24.         For j = l2 To u2
    
25.             a(i, j) = js.eval("a[" & i - l1 & "][" & j - l2 & "]")
    
26.         Next
    
27.     Next
    
28. End Sub

复制代码

jiminyanyan

杜老师的代码比较高深。。。

Nsp=娜！再来#

duquancai 发表于 2018-8-5 20:36

运行时错误'429
ActiveX部件不能创建对象

Nsp=娜！再来#

一把小刀闯天下 发表于 2018-8-5 20:27
Option Explicit

Sub test()

C列的内容没有跟着一起显示哦

duquancai

Nsp=娜！再来# 发表于 2018-8-5 20:55
运行时错误'429
ActiveX部件不能创建对象

64位office不能用，32位的office测试没问题。

Nsp=娜！再来#

duquancai 发表于 2018-8-5 21:01
64位office不能用，32位的office测试没问题。

好的，谢谢老师！

一把小刀闯天下

Nsp=娜！再来# 发表于 2018-8-5 20:57
C列的内容没有跟着一起显示哦

'你也没有讲清楚哦，练练打字吧

duquancai

Nsp=娜！再来# 发表于 2018-8-5 21:05
好的，谢谢老师！

我给你改一个64位office版本的  也能用的代码，请测试！

1. Sub main()
   
2.     Dim arr, j$, r&, i&, s$
   
3.     r = Cells(Rows.Count, 1).End(3).Row: arr = Range("a1:c" & r)
   
4.     For i = 2 To r: s = s & "," & arr(i, 1): Next
   
5.     j = "o={},i=0,r=/''/;'" & s & "'.replace(/[^,]+/g,function(s){o[s]=i++;});for(k in o)r+='|'+k;"
   
6.     j = j & "function f(k){return o.hasOwnProperty(k)?o[k]:i;};"
   
7.     j = j & "function q(x,y){return f((m=x[0].match(r))?m[0]:'')-f((n=y[0].match(r))?n[0]:'');};"
   
8.     Call mySort(arr, j, 2, 2, r, 3)
   
9.     Range("e1").Resize(r, 3) = arr
   
10.     MsgBox "ok!"
    
11. End Sub
    
12. Sub mySort(ByRef a, ByVal p$, ByVal l1&, ByVal l2&, ByVal u1&, ByVal u2&)
    
13.     Dim js As Object, D As Object, i&, j&, s$, sr$
    
14.    Set D = CreateObject("htmlfile"): Set js = D.parentWindow
    
15.     For i = l1 To u1
    
16.         For j = l2 To u2
    
17.             s = s & "," & "'" & a(i, j) & "'"
    
18.         Next
    
19.         sr = sr & "," & "[" & Mid(s, 2) & "]": s = Empty
    
20.     Next
    
21.     js.execScript "a=" & "[" & Mid(sr, 2) & "]" & ";" & p & "a.sort(q);"
    
22.     For i = l1 To u1
    
23.         For j = l2 To u2
    
24.             a(i, j) = js.eval("a[" & i - l1 & "][" & j - l2 & "]")
    
25.         Next
    
26.     Next
    
27. End Sub

复制代码