Excel 利用VBA自动排序的问题

一把小刀闯天下

hugh1236 发表于 2018-7-27 15:14
大佬不好意思，新手上路，想法太简单了。而且这表一直被要求改这改那，这个又是涉密的文件，只好自己仿照 ...

'好像差不多，有问题留言

Option Explicit

Sub test()
  Dim arr, i, j, k, kk, a, b, brr
  arr = Range("a6:j" & Cells(Rows.Count, "b").End(xlUp).Row + 1)
  brr = arr
  Call dsort(arr, 1, UBound(arr, 1) - 1, 4)
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If arr(j, 4) <> arr(j + 1, 4) Then
        a = i - 1: b = j + 1
        For k = i To j
          If arr(k, 5) = "甲" Then
            b = b - 1
            For kk = 1 To UBound(arr, 2): brr(b, kk) = arr(k, kk): Next
          Else
            a = a + 1
            For kk = 1 To UBound(arr, 2): brr(a, kk) = arr(k, kk): Next
          End If
        Next
        For k = i To j
          For kk = 1 To UBound(arr, 2): arr(k, kk) = brr(k, kk): Next
        Next
        If a <> i - 1 Then Call dsort(arr, i, a, 10)
        If b <> j + 1 Then Call dsort(arr, b, j, 10)
        i = j: Exit For
      End If
  Next j, i
  [l6].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub

Function dsort(arr, first, last, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = i + 1 To last
      If arr(i, key) < arr(j, key) Then
        For k = 1 To UBound(arr, 2)
          t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
        Next
      End If
  Next j, i
End Function

hugh1236

一把小刀闯天下 发表于 2018-7-27 16:09
'好像差不多，有问题留言

Option Explicit

大神非常感谢，不过还得麻烦下你，本来已经达到我设想的排序了，我们领导又加了1个条件，然后我又添加了一个排序（条件3），可是不管我将这段放在哪里都不能满足领导要的排序。现在的要求是“条件”>“条件3”>“条件1”，“条件2”还是降序，“条件1”中同一项中“条件3”按自定义排序（“AAA”,"BBB","CCC"）,“条件1”还是“甲”排在后面。就是说“条件”A这类中“条件1”为“甲”的全部放在最后，并按“条件3”排序。其实，“条件1”的数据只有遇到“甲”的时候，才需要将它放在“条件”A类的最后，其它时候“条件1”并不参与排序。因为这个表一直在讨论要达到什么程度，所以我严重怀疑领导可能还要加条件，如果再加我要怎么改？还有就是A列能不能不参与排序，我想让它保持原有的数据（里面为公式），排序后这列变数值了。还请大神帮帮忙，谢谢！

1. <div class="blockcode"><blockquote>Option Explicit
   
2. 
   
3. Const TITLENUM = 5 '标题行数量，这里为1行，修改
   
4. Const COL_1 = 6, COL_2 = 13, COL_3 = 5 '"条件1"、"条件2"、"条件"的对应的列号，修改
   
5. Const FINDSTR = "甲" '查找的字符串，修改
   
6. 
   
7. 
   
8. Sub 按钮1_Click()
   
9. 
   
10.     Application.ScreenUpdating = False
    
11.       With Sheet1.Range("B6:o" & Range("A100").End(xlUp).Row)
    
12. '--------------------------------------------------------------------------------------------
    
13. Dim arr, i, j, k, kk, a, b, brr
    
14.   arr = Range("a6:o" & Cells(Rows.Count, "d").End(xlUp).Row + 1)    '源数据工作表及位置
    
15.   brr = arr
    
16.   Call dsort(arr, 1, UBound(arr, 1) - 1, COL_3)
    
17.   For i = 1 To UBound(arr, 1) - 1
    
18.     For j = i To UBound(arr, 1) - 1
    
19.       If arr(j, COL_3) <> arr(j + 1, COL_3) Then
    
20.         a = i - 1: b = j + 1
    
21.         For k = i To j
    
22.           If arr(k, COL_1) = FINDSTR Then
    
23.             b = b - 1
    
24.             For kk = 1 To UBound(arr, 2): brr(b, kk) = arr(k, kk): Next
    
25.           Else
    
26.             a = a + 1
    
27.             For kk = 1 To UBound(arr, 2): brr(a, kk) = arr(k, kk): Next
    
28.           End If
    
29.         Next
    
30.         For k = i To j
    
31.           For kk = 1 To UBound(arr, 2): arr(k, kk) = brr(k, kk): Next
    
32.         Next
    
33.         If a <> i - 1 Then Call dsort(arr, i, a, COL_2)
    
34.         If b <> j + 1 Then Call dsort(arr, b, j, COL_2)
    
35.         i = j: Exit For
    
36.       End If
    
37.   Next j, i
    
38.   [a6].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    
39. '---------------------------------------对条件3排序------------------------------------------
    
40.        Application.AddCustomList ListArray:=Array("AAA", "BBB", "CCC")
    
41.         .Sort Key1:=Range("C6"), Order1:=1, Header:=xlNo, OrderCustom:=Application.CustomListCount + 1
    
42.         Application.DeleteCustomList ListNum:=Application.CustomListCount
    
43. '--------------------------------------------------------------------------------------------
    
44.         Application.AddCustomList ListArray:=Array("A", "C", "B")
    
45.         .Sort Key1:=Range("E6"), Order1:=1, Header:=xlNo, OrderCustom:=Application.CustomListCount + 1
    
46.         Application.DeleteCustomList ListNum:=Application.CustomListCount
    
47.     End With
    
48.    
    
49.     Application.ScreenUpdating = True
    
50. End Sub
    
51. 
    
52. 
    
53. Function dsort(arr, first, last, key)
    
54.   Dim i, j, k, t
    
55.   For i = first To last - 1
    
56.     For j = i + 1 To last
    
57.       If arr(i, key) < arr(j, key) Then
    
58.         For k = 1 To UBound(arr, 2)
    
59.           t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
    
60.         Next
    
61.       End If
    
62.   Next j, i
    
63. End Function
    

复制代码

hugh1236

hugh1236 发表于 2018-7-30 09:47
大神非常感谢，不过还得麻烦下你，本来已经达到我设想的排序了，我们领导又加了1个条件，然后我又添加了 ...

A列不参与排序，改成这样就可以了
Range("B6:o" & Cells(Rows.Count, "d").End(xlUp).Row + 1)
[B6].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
嘻嘻

hugh1236

mikezhan 发表于 2018-7-30 13:08
Sub test()
Dim arr, brr, ar1, ar2, crr()
Set dic = CreateObject("scripting.dictionary")

感谢，不过我的表有变动了，可以看下回复中我提到的，如果可以的话，可以帮忙看看

LMY123

ADO,数组排序

一把小刀闯天下

hugh1236 发表于 2018-7-30 09:47
大神非常感谢，不过还得麻烦下你，本来已经达到我设想的排序了，我们领导又加了1个条件，然后我又添加了 ...

'22楼附件

'感觉主条件只是一个摆设，也就是你给别人挖的坑，因为你要手工操作它

'可以继续加条件，如果多于3个我就加个条件数组来处理，就算100个条件也没有问题

'如果数据量超过1000行给你换个排序函数，不然效率将会变得很差

Option Explicit

Sub test()
  Dim arr, i, j, k, kk, a, b, brr
  With Sheets("sheet1")
    arr = .Range("a6:o" & .Cells(Rows.Count, "b").End(xlUp).Row + 1)
  End With
  brr = arr
  Call dsort(arr, 1, UBound(arr, 1) - 1, 5) '这行可以删除，就是你挖的坑
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If arr(j, 3) <> arr(j + 1, 3) Then
        Call dsort(arr, i, j, 3)
        a = i - 1: b = j + 1
        For k = i To j
          If arr(k, 6) = "甲" Then
            b = b - 1
            For kk = 1 To UBound(arr, 2): brr(b, kk) = arr(k, kk): Next
          Else
            a = a + 1
            For kk = 1 To UBound(arr, 2): brr(a, kk) = arr(k, kk): Next
          End If
        Next
        If a <> i - 1 Then Call dsort(brr, i, a, 13)
        If b <> j + 1 Then Call dsort(brr, b, j, 13)
        i = j: Exit For
      End If
  Next j, i
  With Sheets("sheet3").[a6]
    .Resize(Rows.Count - 5, UBound(arr, 2)).ClearContents
    .Resize(UBound(arr, 1), UBound(arr, 2)) = brr
  End With
End Sub

Function dsort(arr, first, last, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = i + 1 To last
      If arr(i, key) < arr(j, key) Then
        For k = 1 To UBound(arr, 2)
          t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
        Next
      End If
  Next j, i
End Function

hugh1236

一把小刀闯天下 发表于 2018-8-3 07:20
'22楼附件

'感觉主条件只是一个摆设，也就是你给别人挖的坑，因为你要手工操作它

还是不行，我感觉主要的排序是《条件、条件3、条件2》，条件1中就是有个特例，为"甲"的排在后面。
下表是我想达到的排序，手动调的，条件2没显示出来，还是从大到小的顺序。我手动做的话，是先将“条件、条件3、条件2”按自定义排序后将“条件1”为“甲”的剪切放在“条件”为“A”的最后。
大神你看下，能不能靠代码一步到位，感谢！
[tr] [/tr]

条件3	内容2	条件	条件1
AAA	数据20	A	丙
AAA	数据6	A	乙
AAA	数据27	A	乙
AAA	数据15	A	丙
AAA	数据21	A	丙
BBB	数据5	A	丙
BBB	数据22	A	乙
CCC	数据14	A	乙
AAA	数据24	A	甲
AAA	数据16	A	甲
AAA	数据28	A	甲
BBB	数据18	A	甲
CCC	数据25	A	甲
AAA	数据10	C	庚
AAA	数据4	C	己
AAA	数据9	C	庚
AAA	数据7	C	己
BBB	数据3	C	己
CCC	数据8	C	庚
AAA	数据23	B	丁
AAA	数据19	B	戊
AAA	数据2	B	丁
AAA	数据11	B	丁
AAA	数据17	B	丁
AAA	数据13	B	戊
BBB	数据12	B	丁
BBB	数据26	B	戊
CCC	数据1	B	戊

一把小刀闯天下

hugh1236 发表于 2018-8-6 09:55
还是不行，我感觉主要的排序是《条件、条件3、条件2》，条件1中就是有个特例，为"甲"的排在后面。
下 ...

又进入了看不懂模式，咱直接投降算了

一个文字题但我就是理解不了，你还是问问其他老师吧，我相信你自己肯定知道要想解决什么问题