求个多次排序再复制粘贴代码

779846526

排序再粘贴问题.zip (285.08 KB, 下载次数: 8)

2019-1-21 16:57 上传

点击文件名下载附件

请路过的帮忙写个按要求排序再粘贴的代码

779846526

不知我的意思说清楚了吗，请路过的看下回个话吧

清风竹-

779846526 发表于 2019-1-21 19:43
不知我的意思说清楚了吗，请路过的看下回个话吧

Sub 整理学生课表()
m = [a65536].End(3).Row
arr1 = Sheets("第1节").Range("c2:d" & m)
arr2 = Sheets("第2节").Range("c2:d" & m)
arr3 = Sheets("第3节").Range("c2:d" & m)
arr = Array(arr1, arr2, arr3)
   For i = 0 To 8 Step 4
       Range("A1:O" & m).Sort Key1:=Range("E2").Offset(0, i), Order1:=xlAscending, Header:=xlGuess
       k = i / 4
       Range("E2").Offset(0, 1 + i).Resize(m - 1, 2) = arr(k)
   Next
    Range("A1:O" & m).Sort Key1:=Range("a2"), Order1:=xlAscending, Header:=xlGuess
End Sub
请测试。

扑腾

请见附件：

扑腾

如能解决问题，功劳完全是前任分节建表同学的，我只是增加了两个with

清风竹-

779846526 发表于 2019-1-21 19:43
不知我的意思说清楚了吗，请路过的看下回个话吧

请看附件。

YZC51

学习老师的代码！谢谢老师！
Sub 整理学生课表()
m = [a65536].End(3).Row
arr1 = Sheets("第1节").Range("c2:d" & m)
arr2 = Sheets("第2节").Range("c2:d" & m)
arr3 = Sheets("第3节").Range("c2:d" & m)
arr = Array(arr1, arr2, arr3)
    For i = 0 To 8 Step 4
        [a1].CurrentRegion.Sort [c1], 1, , , , , , 1
        [a1].CurrentRegion.Sort Cells(1, i + 5), 1, , , , , , 1
        k = i / 4
        Debug.Print i, k
        Range("E2").Offset(0, 1 + i).Resize(m - 1, 2) = arr(k)
    Next
    [a1].CurrentRegion.Sort [a1], 1, , , , , , 1
'    Range("A1:O" & m).Sort Key1:=Range("a2"), Order1:=xlAscending, Header:=xlGuess
End Sub