excel用VBA按自定义排序

tonghau · 发表于 2021-12-2 16:44

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

905738810 · 发表于 2021-12-2 16:56

本帖最后由 905738810 于 2021-12-3 08:08 编辑

能上传了

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

tonghau · 发表于 2021-12-2 17:24

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

好的，谢谢

chxw68 · 发表于 2021-12-2 18:34

Sub test()
Dim r%, i%, c%, j%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To r
If InStr("姓名性别部门次数", .Cells(i, 1).Value) <> 0 Then
r1 = .Cells(i, 1).End(xlDown).Row
With .Sort
.SortFields.Clear
.SortFields.Add Key:=.Parent.Cells(i, 1), Order:=xlAscending, CustomOrder:="姓名,性别,部门,次数"
.SetRange .Parent.Range(.Parent.Cells(i, 1), .Parent.Cells(r1, 4))
.Header = xlNo
.Orientation = xlLeftToRight
.Apply
End With
End If
Next
End With
End Sub

复制代码

chxw68 · 发表于 2021-12-2 18:35

详见附件。

feto · 发表于 2021-12-2 18:53

本帖最后由 feto 于 2021-12-3 09:35 编辑

仅供参考。

复制代码

xiangbaoan · 发表于 2021-12-2 19:34

Sub test1()
Dim ar, Dict As Object, i As Long, p As Long
Set Dict = CreateObject("Scripting.Dictionary")
ar = Split("姓名性别部门次数")
For i = 0 To UBound(ar)
Dict(ar(i)) = UBound(ar) + 1 - i
Next
ar = Range("D1", Cells(Rows.Count, 1).End(xlUp).Offset(1))
For i = 1 To UBound(ar) - 1
If Dict.Exists(ar(i, 1)) Then p = i
If Len(ar(i, 1)) And Len(ar(i + 1, 1)) = 0 Then
QuickSort Dict, ar, p, i, 1, UBound(ar, 2), p
End If
Next
Range("M1").Resize(UBound(ar), UBound(ar, 2)) = ar
Set Dict = Nothing
End Sub
Function QuickSort(Dict As Object, ar, 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
j = l
x = r
p = Dict(ar(k, (l + r) \ 2))
While j <= x
Do While j < r
If Dict(ar(k, j)) > p Then j = j + 1 Else Exit Do
Loop
Do While x > l
If p > Dict(ar(k, x)) Then x = x - 1 Else Exit Do
Loop
If j < x Then
For y = t To b
v = ar(y, j): ar(y, j) = ar(y, x): ar(y, x) = v
Next
j = j + 1: x = x - 1
Else
If j = x Then j = j + 1: x = x - 1
End If
Wend
If l < x Then QuickSort Dict, ar, t, b, l, x, k
If j < r Then QuickSort Dict, ar, t, b, j, r, k
End Function

复制代码

xiangbaoan · 发表于 2021-12-2 20:01

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

		自动登录	找回密码
密码			免费注册

[求助] excel用VBA按自定义排序