工作表按名称排序（VBA80集第25讲课后练习题）上交专贴

丫丫2022

学习

hammerfly

让我看看答案

宁致贤

辛苦了

wj65134

来向各位高手们学习一下

nonemoonsun

学习again

leoxxx

下载的附件打不开。

leoxxx

1. Sub 工作表排序之希尔排序()
   
2.     Dim arr, temp, x, y, t As Integer, g As Integer, n As String
   
3.     ReDim arr(1 To Sheets.Count) '重新分配数组的存储空间
   
4.     For x = 1 To UBound(arr)
   
5.         arr(x) = Sheets(x).Name
   
6.     Next x
   
7.     t = UBound(arr) '总长度
   
8.     g = 1 '间隔初始化
   
9.     If t > 13 Then
   
10.         Do While g < t
    
11.             g = g * 3 + 1
    
12.         Loop
    
13.         g = g \ 9
    
14.     End If
    
15.     Do While g
    
16.         For x = 1 + g To UBound(arr)
    
17.             temp = arr(x) '储存当前元素
    
18.             For y = x - g To 1 Step -g '上一个元素到第一个元素，步进减g。
    
19.                 If temp >= arr(y) Then Exit For '当前元素大于等于arr(y)则跳出本层For。
    
20.                 arr(y + g) = arr(y) '不满足条件则将arr(y + g)赋值为arr(y)。
    
21.             Next y
    
22.             arr(y + g) = temp '跳出For后执行。将arr(y + g)赋值为当前元素。
    
23.         Next x
    
24.         g = g \ 3
    
25.     Loop
    
26.     n = ActiveSheet.Name '获取当前表名
    
27.     For x = 1 To UBound(arr) - 1
    
28.         Sheets(arr(x)).Move before:=Sheets(arr(UBound(arr))) '移到数组上标之前
    
29.     Next x
    
30.     Sheets(n).Select
    
31. End Sub

复制代码

leoxxx

1. Sub 工作表排序之冒泡法()
   
2.     Dim arr, temp, x, y, n As String
   
3.     ReDim arr(1 To Sheets.Count) '重新分配数组的存储空间
   
4.     For x = 1 To UBound(arr)
   
5.         arr(x) = Sheets(x).Name
   
6.     Next x
   
7.     For x = 1 To UBound(arr) - 1
   
8.         For y = x + 1 To UBound(arr)
   
9.             If arr(x) > arr(y) Then
   
10.                 temp = arr(x)
    
11.                 arr(x) = arr(y)
    
12.                 arr(y) = temp
    
13.                 '如果x大于y则互换位置。
    
14.             End If
    
15.         Next y
    
16.     Next x
    
17.     n = ActiveSheet.Name '获取当前表名
    
18.     For x = 1 To UBound(arr) - 1
    
19.         Sheets(arr(x)).Move before:=Sheets(arr(UBound(arr))) '移到数组上标之前
    
20.     Next x
    
21.     Sheets(n).Select
    
22. End Sub
    
23. 
    
24. Sub 工作表排序之选择法()
    
25.     Dim arr, temp, x, y, m As Integer, n As String
    
26.     ReDim arr(1 To Sheets.Count) '重新分配数组的存储空间
    
27.     For x = 1 To UBound(arr)
    
28.         arr(x) = Sheets(x).Name
    
29.     Next x
    
30.     For x = 1 To UBound(arr) - 1
    
31.         m = x '索引初始化
    
32.         For y = x + 1 To UBound(arr)
    
33.             If arr(m) > arr(y) Then m = y '查找最小索引。同行不用End If。
    
34.         Next y
    
35.         temp = arr(x)
    
36.         arr(x) = arr(m)
    
37.         arr(m) = temp
    
38.         '当前值与索引与互换位置
    
39.     Next x
    
40.     n = ActiveSheet.Name '获取当前表名
    
41.     For x = 1 To UBound(arr) - 1
    
42.         Sheets(arr(x)).Move before:=Sheets(arr(UBound(arr))) '移到数组上标之前
    
43.     Next x
    
44.     Sheets(n).Select
    
45. End Sub
    
46. 
    
47. Sub 工作表排序之插入法()
    
48.     Dim arr, temp, x, y, n As String
    
49.     ReDim arr(1 To Sheets.Count) '重新分配数组的存储空间
    
50.     For x = 1 To UBound(arr)
    
51.         arr(x) = Sheets(x).Name
    
52.     Next x
    
53.     For x = 2 To UBound(arr)
    
54.         temp = arr(x) '储存当前元素
    
55.         For y = x - 1 To 1 Step -1 '上一个元素到第一个元素，步进减1。
    
56.             If temp >= arr(y) Then Exit For '当前元素大于等于arr(y)则跳出本层For。
    
57.             arr(y + 1) = arr(y) '不满足条件则将arr(y + 1)赋值为arr(y)。
    
58.         Next y
    
59.         arr(y + 1) = temp '跳出For后执行。将arr(y + 1)赋值为当前元素。
    
60.     Next x
    
61.     n = ActiveSheet.Name '获取当前表名
    
62.     For x = 1 To UBound(arr) - 1
    
63.         Sheets(arr(x)).Move before:=Sheets(arr(UBound(arr))) '移到数组上标之前
    
64.     Next x
    
65.     Sheets(n).Select
    
66. End Sub
    
67. 
    
68. Sub 打乱顺序()
    
69.     Dim arr, arr1, i, r As Integer, k As Integer, n As String
    
70.     ReDim arr(1 To Sheets.Count), arr1(1 To Sheets.Count) '重新分配数组的存储空间
    
71.     For i = 1 To UBound(arr1)
    
72.         arr1(i) = Sheets(i).Name
    
73.     Next i
    
74.     k = UBound(arr)
    
75.     Randomize 'https://learn.microsoft.com/zh-cn/office/vba/language/reference/user-interface-help/randomize-statement
    
76.     For i = LBound(arr) To UBound(arr)
    
77.         r = Int((k - LBound(arr) + 1) * Rnd + LBound(arr)) 'https://learn.microsoft.com/zh-cn/office/vba/language/reference/user-interface-help/rnd-function
    
78.         arr(i) = arr1(r) '将arr1的随机值存储到arr
    
79.         arr1(r) = arr1(k)
    
80.         arr1(k) = arr(i) '与数组末位交换位置
    
81.         k = k - 1 '数组末位-1以避免重复取值
    
82.     Next i
    
83.     n = ActiveSheet.Name '获取当前表名
    
84.     For i = 1 To UBound(arr) - 1
    
85.         Sheets(arr(i)).Move before:=Sheets(arr(UBound(arr))) '移到数组上标之前
    
86.     Next i
    
87.     Sheets(n).Select
    
88. End Sub

复制代码