VBA按规定的单位和职务排序

20041022rsh

xiangbaoan 发表于 2021-2-14 10:56

先谢谢啦，晚上测试。

20041022rsh

3190496160 发表于 2021-2-14 10:59

先谢啦，下了晚上测试！

20041022rsh

感谢两位高手，两种方法都很好，默默学习中。

20041022rsh

第一次来HOME，感觉找到组织了。

准提部林

Sub TEST_A1()
With Range([B5], [D65536].End(xlUp)(1, 2))
     .Columns(4) = "=10^9+MATCH(B5,F:F,)*1000+MATCH(C5,G:G,)&D5"
     .Sort Key1:=.Item(4), Order1:=xlAscending, Header:=xlNo
     .Columns(4).Clear
End With
End Sub

一個輔助列公式即可簡單達成~~

xiangbaoan

Option Explicit

Sub MySort2()
  Dim ar, d As Object, i&, k&, y&
  Set d = CreateObject("Scripting.Dictionary")
  ar = Range("F4").CurrentRegion
  For i = 2 To UBound(ar)
    If Len(ar(i, 1)) Then
      For y = 2 To UBound(ar)
        If Len(ar(y, 2)) Then: k = k + 1: d(ar(i, 1) & "|" & ar(y, 2)) = k
      Next
    End If
  Next
  ar = Range("B4").CurrentRegion.Resize(, 4)
  For i = 2 To UBound(ar)
    y = d(ar(i, 1) & "|" & ar(i, 2)): If y = 0 Then y = k + 1
    ar(i, 4) = y
  Next
  QuickSort ar, 2, i - 1, 1, UBound(ar, 2), UBound(ar, 2)
  Range("B4").Resize(UBound(ar), 3) = ar
  Set d = Nothing
End Sub

Sub QuickSort(br, t As Long, b As Long, l As Long, r As Long, k As Long)
  Dim i As Long, j As Long, x As Long, y As Long, p As Long, v
  i = t: y = b: p = br((t + b) \ 2, k)
  While i <= y
    Do While i < b
      If br(i, k) < p Then i = i + 1 Else Exit Do
    Loop
    Do While y > t
      If br(y, k) > p Then y = y - 1 Else Exit Do
    Loop
    If i < y Then
      For x = l To r
        v = br(i, x): br(i, x) = br(y, x): br(y, x) = v
      Next
      i = i + 1: y = y - 1
    Else
      If i = y Then i = i + 1: y = y - 1
    End If
  Wend
  If i < b Then QuickSort br, i, b, l, r, k
  If y > t Then QuickSort br, t, y, l, r, k
End Sub

xiangbaoan

Option Explicit

Sub test()'还凑一种方法
  Dim Cn As Object, Sq As String, s(1) As String
  Set Cn = CreateObject("ADODB.Connection")
  Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
  Worksheets(1).Activate
  s(0) = "'" & Join(WorksheetFunction.Transpose(Range("F5", Range("F678").End(xlUp))), ",") & "'"
  s(1) = "'" & Join(WorksheetFunction.Transpose(Range("G5", Range("G678").End(xlUp))), ",") & "'"
  Sq = "SELECT * FROM [" & ActiveSheet.Name & "$B4:D] ORDER BY INSTR(" & s(0) & ",单位),INSTR(" & s(1) & ",职位)"
  Range("B5").CopyFromRecordset Cn.Execute(Sq)
  Cn.Close: Set Cn = Nothing
End Sub