excel用VBA按自定义排序

tonghau

每次导出的表里每一列的顺序都是不一样的，运行之后要按照固定的姓名、性别、部门、次数的顺序排列，行不需要排列，只调整，整列的位置。请教各位老师，这VBA要怎么弄？
谢谢！

905738810

能上传了 工作簿2.rar (244.72 KB, 下载次数: 6)

2021-12-3 08:08 上传

点击文件名下载附件

tonghau

905738810 发表于 2021-12-2 16:56
额，附件上传超限了,只能明天了，EH这点太不友好了

好的，谢谢

chxw68

1. Sub test()
   
2.   Dim r%, i%, c%, j%
   
3.   Application.ScreenUpdating = False
   
4.   Application.DisplayAlerts = False
   
5.   With Worksheets("sheet1")
   
6.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
7.     For i = 1 To r
   
8.       If InStr("姓名性别部门次数", .Cells(i, 1).Value) <> 0 Then
   
9.         r1 = .Cells(i, 1).End(xlDown).Row
   
10.         With .Sort
    
11.           .SortFields.Clear
    
12.           .SortFields.Add Key:=.Parent.Cells(i, 1), Order:=xlAscending, CustomOrder:="姓名,性别,部门,次数"
    
13.           .SetRange .Parent.Range(.Parent.Cells(i, 1), .Parent.Cells(r1, 4))
    
14.           .Header = xlNo
    
15.           .Orientation = xlLeftToRight
    
16.           .Apply
    
17.         End With
    
18.       End If
    
19.     Next
    
20.   End With
    
21. End Sub
    

复制代码

chxw68

详见附件。

feto

仅供参考。

1. Sub Test()
   
2.    
   
3.     bt = "姓名/性别/部门/次数"
   
4.    
   
5.     r = Cells(Rows.Count, 1).End(3).Row
   
6.     ar = Range("A1:D" & r).Value
   
7.    
   
8.     ReDim br(1 To r, 1 To 4)
   
9.     Set dic = CreateObject("scripting.dictionary")
   
10.    
    
11. '----------------------------------------------------------
    
12.     For i = 1 To r
    
13.       If InStr(bt, ar(i, 1)) Then
    
14.         For j = 1 To 4
    
15.           dic(ar(i, j)) = j
    
16.         Next j
    
17.       End If
    
18.       
    
19.       br(i, 1) = ar(i, dic("姓名"))
    
20.       br(i, 2) = ar(i, dic("性别"))
    
21.       br(i, 3) = ar(i, dic("部门"))
    
22.       br(i, 4) = ar(i, dic("次数"))
    
23.     Next i
    
24. '----------------------------------------------------------
    
25.     Cells(1, "G").Resize(r, 4) = br
    
26. 
    
27. End Sub

复制代码

xiangbaoan

1. Sub test1()
   
2.   Dim ar, Dict As Object, i As Long, p As Long
   
3.   Set Dict = CreateObject("Scripting.Dictionary")
   
4.   ar = Split("姓名 性别 部门 次数")
   
5.   For i = 0 To UBound(ar)
   
6.     Dict(ar(i)) = UBound(ar) + 1 - i
   
7.   Next
   
8.   ar = Range("D1", Cells(Rows.Count, 1).End(xlUp).Offset(1))
   
9.   For i = 1 To UBound(ar) - 1
   
10.     If Dict.Exists(ar(i, 1)) Then p = i
    
11.     If Len(ar(i, 1)) And Len(ar(i + 1, 1)) = 0 Then
    
12.       QuickSort Dict, ar, p, i, 1, UBound(ar, 2), p
    
13.     End If
    
14.   Next
    
15.   Range("M1").Resize(UBound(ar), UBound(ar, 2)) = ar
    
16.   Set Dict = Nothing
    
17. End Sub
    
18. 
    
19. Function QuickSort(Dict As Object, ar, t As Long, b As Long, l As Long, r As Long, k As Long)
    
20.   Dim i As Long, j As Long, x As Long, y As Long, p As Long, v
    
21.   j = l
    
22.   x = r
    
23.   p = Dict(ar(k, (l + r) \ 2))
    
24.   While j <= x
    
25.     Do While j < r
    
26.       If Dict(ar(k, j)) > p Then j = j + 1 Else Exit Do
    
27.     Loop
    
28.     Do While x > l
    
29.       If p > Dict(ar(k, x)) Then x = x - 1 Else Exit Do
    
30.     Loop
    
31.     If j < x Then
    
32.       For y = t To b
    
33.         v = ar(y, j): ar(y, j) = ar(y, x): ar(y, x) = v
    
34.       Next
    
35.       j = j + 1: x = x - 1
    
36.     Else
    
37.       If j = x Then j = j + 1: x = x - 1
    
38.     End If
    
39.   Wend
    
40.   If l < x Then QuickSort Dict, ar, t, b, l, x, k
    
41.   If j < r Then QuickSort Dict, ar, t, b, j, r, k
    
42. End Function

复制代码

xiangbaoan

附件测试.zip (16.41 KB, 下载次数: 11)

2021-12-2 20:00 上传

点击文件名下载附件