[已解决]按要求排列列

wingotoo

我有一个sheet2如下图



现在要求按照另外一个sheet（名字叫排序）所示，将原来sheet2的列 重新按照“排序”的顺序排列，


结果显示如下：（ sheet[排序] 出现的"姓名""班级"字段则按照该顺序优先排序，其他的字段不改变顺序接着排下去）


如何设计代码？求助各路大神
需求.rar (6.48 KB, 下载次数: 6)

2016-2-16 22:13 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

雪舞子

2016-2-16 23:44

1. Sub test()
   
2.     Dim d As Object, ar, i%
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     With Sheets("排序")
   
5.         arr = .Range("a1").CurrentRegion
   
6.         For i = 1 To UBound(arr, 2)
   
7.             d(arr(1, i)) = ""
   
8.         Next
   
9.         arr = Sheet2.Range("a1").CurrentRegion
   
10.         For i = 1 To UBound(arr, 2)
    
11.             d(arr(1, i)) = ""
    
12.         Next
    
13.         .[a1].Resize(UBound(arr), i - 1) = arr
    
14.         Application.AddCustomList ListArray:=d.keys
    
15.         .Range("a1:f" & UBound(arr)).Sort key1:=.Range("a1"), order1:=1, Orientation:=2, Header:=xlNo, OrderCustom:=Application.CustomListCount + 1
    
16.         Application.DeleteCustomList Application.CustomListCount
    
17.     End With
    
18. End Sub

复制代码

需求.rar (15.84 KB, 下载次数: 8)

2016-2-16 23:44 上传

点击文件名下载附件

跳转到最佳答案楼层

sry660

1. Sub 排序()
   
2.     Dim arr, brr, i&, j&, n&
   
3.     arr = Sheet2.[a1].CurrentRegion
   
4.     ReDim brr(1 To UBound(arr), 1 To 6)
   
5.     For i = 1 To UBound(arr)
   
6.         n = n + 1
   
7.         brr(n, 1) = arr(i, 3): brr(n, 2) = arr(i, 1)
   
8.         For j = 3 To 5
   
9.             brr(n, j) = arr(i, j + 1)
   
10.         Next
    
11.         brr(n, 6) = arr(i, 2)
    
12.     Next
    
13.     With Sheet1
    
14.         .[a1:f10000].ClearContents
    
15.         .[a1].Resize(n, 6) = brr
    
16.     End With
    
17. End Sub

复制代码

雪舞子

1. Sub test()
   
2.     Dim d As Object, ar, i%
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     With Sheets("排序")
   
5.         arr = .Range("a1").CurrentRegion
   
6.         For i = 1 To UBound(arr, 2)
   
7.             d(arr(1, i)) = ""
   
8.         Next
   
9.         arr = Sheet2.Range("a1").CurrentRegion
   
10.         For i = 1 To UBound(arr, 2)
    
11.             d(arr(1, i)) = ""
    
12.         Next
    
13.         .[a1].Resize(UBound(arr), i - 1) = arr
    
14.         Application.AddCustomList ListArray:=d.keys
    
15.         .Range("a1:f" & UBound(arr)).Sort key1:=.Range("a1"), order1:=1, Orientation:=2, Header:=xlNo, OrderCustom:=Application.CustomListCount + 1
    
16.         Application.DeleteCustomList Application.CustomListCount
    
17.     End With
    
18. End Sub

复制代码

需求.rar (15.84 KB, 下载次数: 8)

2016-2-16 23:44 上传

点击文件名下载附件

wingotoo

雪舞子 发表于 2016-2-16 23:44

你好 每次运行完程序都奔溃退出  什么原因？

雪舞子

wingotoo 发表于 2016-2-17 21:00
你好 每次运行完程序都奔溃退出  什么原因？

单步调试一下，到哪步退出的。

wingotoo

雪舞子 发表于 2016-2-17 22:10
单步调试一下，到哪步退出的。

单步运行没问题，运行完也可以按要求排列。

但是按保存就出现 重新启动的提示 然后下次打开就是修复了
是因为用了字典后就不稳定么？

雪舞子

wingotoo 发表于 2016-2-17 23:47
单步运行没问题，运行完也可以按要求排列。

但是按保存就出现 重新启动的提示 然后下次打开就是修复了 ...

正常调试通过应该与代码无关，
是不是你的系统不稳定造成的，
重新启动一下系统试试。