[已解决]求b随c绑定每隔4行一组快速排序的vba程序

rangevba

在区域b5:c30000中，数据以行为单位每4行一组，各组数据以c单元格中的数字参与排序，同行号b随c绑定排序，每隔4行一组依次排序，数字按从大到小降序排序.排序后b列数据放到以e5开始的e列。c列数据放到以f5开始的f列。

附件中的排序速度太慢，请用数组排序法，谢谢！


排序.zip (16.31 KB, 下载次数: 6)

2016-6-25 17:14 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-6-25 20:48

1. 
   
2. Sub xx()
   
3.     Dim i&, tempA, tempB, j&, k&, arr, n%
   
4.     Range("h5:i8576").ClearContents
   
5.     arr = Range("b5:c" & Range("c1048576").End(3).Row)
   
6.     y = Int(UBound(arr, 1) / 4) * 4
   
7.     For k = 4 To y Step 4
   
8.         For i = k To k - 2 Step -1
   
9.             For j = k - 3 To i - 1
   
10.                 If arr(j, 2) < arr(j + 1, 2) Then
    
11.                     tempA = arr(j, 2)
    
12.                     tempB = arr(j, 1)
    
13.                     arr(j, 2) = arr(j + 1, 2)
    
14.                     arr(j, 1) = arr(j + 1, 1)
    
15.                     arr(j + 1, 2) = tempA
    
16.                     arr(j + 1, 1) = tempB
    
17.                 End If
    
18.             Next
    
19.         Next
    
20.     Next
    
21.     n = UBound(arr, 1) Mod 4
    
22.     If n >0 Then
    
23.         For i = UBound(arr, 1) To k - 4 + n - 2 Step -1
    
24.             For j = k - 4 + 1 To i - 1
    
25.                 If arr(j, 2) < arr(j + 1, 2) Then
    
26.                     tempA = arr(j, 2)
    
27.                     tempB = arr(j, 1)
    
28.                     arr(j, 2) = arr(j + 1, 2)
    
29.                     arr(j, 1) = arr(j + 1, 1)
    
30.                     arr(j + 1, 2) = tempA
    
31.                     arr(j + 1, 1) = tempB
    
32.                 End If
    
33.             Next
    
34.         Next
    
35.     End If
    
36.     Sheet1.Range("E5").Resize(UBound(arr, 1), 2) = arr
    
37. End Sub

复制代码

跳转到最佳答案楼层

老司机带带我

1. 
   
2. Sub xx()
   
3.     Dim i&, tempA, tempB, j&, k&, arr, n%
   
4.     Range("h5:i8576").ClearContents
   
5.     arr = Range("b5:c" & Range("c1048576").End(3).Row)
   
6.     y = Int(UBound(arr, 1) / 4) * 4
   
7.     For k = 4 To y Step 4
   
8.         For i = k To k - 2 Step -1
   
9.             For j = k - 3 To i - 1
   
10.                 If arr(j, 2) < arr(j + 1, 2) Then
    
11.                     tempA = arr(j, 2)
    
12.                     tempB = arr(j, 1)
    
13.                     arr(j, 2) = arr(j + 1, 2)
    
14.                     arr(j, 1) = arr(j + 1, 1)
    
15.                     arr(j + 1, 2) = tempA
    
16.                     arr(j + 1, 1) = tempB
    
17.                 End If
    
18.             Next
    
19.         Next
    
20.     Next
    
21.     n = UBound(arr, 1) Mod 4
    
22.     If n >0 Then
    
23.         For i = UBound(arr, 1) To k - 4 + n - 2 Step -1
    
24.             For j = k - 4 + 1 To i - 1
    
25.                 If arr(j, 2) < arr(j + 1, 2) Then
    
26.                     tempA = arr(j, 2)
    
27.                     tempB = arr(j, 1)
    
28.                     arr(j, 2) = arr(j + 1, 2)
    
29.                     arr(j, 1) = arr(j + 1, 1)
    
30.                     arr(j + 1, 2) = tempA
    
31.                     arr(j + 1, 1) = tempB
    
32.                 End If
    
33.             Next
    
34.         Next
    
35.     End If
    
36.     Sheet1.Range("E5").Resize(UBound(arr, 1), 2) = arr
    
37. End Sub

复制代码

rangevba

老司机带带我 发表于 2016-6-25 20:48

老师你好，程序经测试满足要求，谢谢！