[已解决]批量排序的问题

小玲玲

附件 批量排序.rar (166.14 KB, 下载次数: 8)

2016-3-5 13:35 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

雪舞子

2016-3-7 21:25

1. Sub test()
   
2.     Dim i&, j&, k&, m&, n&, x, y, r&
   
3.     Dim arr(1 To 100, 1 To 2), wb, th, wbn$
   
4.     Application.ScreenUpdating = False
   
5.     th = ThisWorkbook.Path & ""
   
6.     wbn = Dir(th & "*.xlsx")
   
7.     Do While Len(wbn)
   
8.         If wbn <> ThisWorkbook.Name Then
   
9.             Set wb = Workbooks.Open(th & wbn)
   
10.             With wb
    
11.                 For m = 1 To Sheets.Count
    
12.                     With .Sheets(m)
    
13.                         r = .[a65536].End(3).Row
    
14.                         If r > 1 Then
    
15.                             n = 0
    
16.                             For i = 1 To r Step 3
    
17.                                 n = n + 1
    
18.                                 arr(n, 1) = .Cells(i, 1).CurrentRegion
    
19.                                 arr(n, 2) = arr(n, 1)(1, 9)
    
20.                                 y = arr(n, 1)
    
21.                                 x = arr(n, 2)
    
22.                                 For j = 1 To n - 1
    
23.                                     If arr(j, 2) > x Then
    
24.                                         For k = n To j + 1 Step -1
    
25.                                             arr(k, 1) = arr(k - 1, 1)
    
26.                                             arr(k, 2) = arr(k - 1, 2)
    
27.                                         Next
    
28.                                         Exit For
    
29.                                     End If
    
30.                                 Next
    
31.                                 arr(j, 1) = y
    
32.                                 arr(j, 2) = x
    
33.                             Next
    
34.                             n = 0
    
35.                             .Cells.ClearContents
    
36.                             For j = 1 To i - 1 Step 3
    
37.                                 n = n + 1
    
38.                                 .Cells(j, 1).Resize(2, 9) = arr(n, 1)
    
39.                             Next
    
40.                         End If
    
41.                     End With
    
42.                 Next
    
43.                 .Close True
    
44.             End With
    
45.             wbn = Dir
    
46.         End If
    
47.     Loop
    
48.     Application.ScreenUpdating = True
    
49.     MsgBox "处理完毕！"
    
50. End Sub
    

复制代码

批量排序.rar (173.64 KB, 下载次数: 12)

2016-3-7 21:25 上传

点击文件名下载附件

跳转到最佳答案楼层

just2seeusmile

雪舞子

1. Sub test()
   
2.     Dim i&, j&, k&, m&, n&, x, y, r&
   
3.     Dim arr(1 To 100, 1 To 2), wb, th, wbn$
   
4.     Application.ScreenUpdating = False
   
5.     th = ThisWorkbook.Path & ""
   
6.     wbn = Dir(th & "*.xlsx")
   
7.     Do While Len(wbn)
   
8.         If wbn <> ThisWorkbook.Name Then
   
9.             Set wb = Workbooks.Open(th & wbn)
   
10.             With wb
    
11.                 For m = 1 To Sheets.Count
    
12.                     With .Sheets(m)
    
13.                         r = .[a65536].End(3).Row
    
14.                         If r > 1 Then
    
15.                             n = 0
    
16.                             For i = 1 To r Step 3
    
17.                                 n = n + 1
    
18.                                 arr(n, 1) = .Cells(i, 1).CurrentRegion
    
19.                                 arr(n, 2) = arr(n, 1)(1, 9)
    
20.                                 y = arr(n, 1)
    
21.                                 x = arr(n, 2)
    
22.                                 For j = 1 To n - 1
    
23.                                     If arr(j, 2) > x Then
    
24.                                         For k = n To j + 1 Step -1
    
25.                                             arr(k, 1) = arr(k - 1, 1)
    
26.                                             arr(k, 2) = arr(k - 1, 2)
    
27.                                         Next
    
28.                                         Exit For
    
29.                                     End If
    
30.                                 Next
    
31.                                 arr(j, 1) = y
    
32.                                 arr(j, 2) = x
    
33.                             Next
    
34.                             n = 0
    
35.                             .Cells.ClearContents
    
36.                             For j = 1 To i - 1 Step 3
    
37.                                 n = n + 1
    
38.                                 .Cells(j, 1).Resize(2, 9) = arr(n, 1)
    
39.                             Next
    
40.                         End If
    
41.                     End With
    
42.                 Next
    
43.                 .Close True
    
44.             End With
    
45.             wbn = Dir
    
46.         End If
    
47.     Loop
    
48.     Application.ScreenUpdating = True
    
49.     MsgBox "处理完毕！"
    
50. End Sub
    

复制代码

批量排序.rar (173.64 KB, 下载次数: 12)

2016-3-7 21:25 上传

点击文件名下载附件