[已解决]一年级学生每周轮换排座求助，谢谢各位老师！

zyq75211 · 发表于 2017-10-13 13:35

各位老师，一年级新生，按要求每周都要进行重新排座，前提是按照第一次的分座座位次序进行竖列依次轮换，横列顺时针轮换进行调换座位，这样使每个学生，每个座位都可以坐到，我想要用VBA进行操作，手工调座太麻烦，根据日期周数，点击后自动轮换。不重复，直到第一次的座位，烦请各位老师指点！详情详见附件。

最佳答案

月排行榜 / 总排行榜

ppp710715

2017-10-14 10:36

Sub pptest()
Dim x%, y%, arr, br(1 To 6, 1 To 8), i%, j%
Dim sh As Worksheet
Set sh = Worksheets("排座")
arr = sh.[c6:j11]
For j = 1 To UBound(arr, 2)
For i = 1 To UBound(arr, 1)
If i = UBound(arr, 1) And j = UBound(arr, 2) Then
x = 1: y = 1: br(x, y) = arr(i, j)
Else
If i = UBound(arr, 1) Then
x = 1: y = j + 1: br(x, y) = arr(i, j)
Else
x = i + 1: y = j: br(x, y) = arr(i, j)
End If
End If
Next
Next
sh.[c6:j11] = br
sh.[m2] = Now() & "已调整座位！"
End Sub

复制代码

跳转到最佳答案楼层

ppp710715 · 发表于 2017-10-13 16:39

如何轮换？看不明白。请发一个效果图

ppp710715 · 发表于 2017-10-14 10:36

这个最佳答案由 ppp710715 给出，感谢 ppp710715 的回答。

单击隐藏图章

Sub pptest()
Dim x%, y%, arr, br(1 To 6, 1 To 8), i%, j%
Dim sh As Worksheet
Set sh = Worksheets("排座")
arr = sh.[c6:j11]
For j = 1 To UBound(arr, 2)
For i = 1 To UBound(arr, 1)
If i = UBound(arr, 1) And j = UBound(arr, 2) Then
x = 1: y = 1: br(x, y) = arr(i, j)
Else
If i = UBound(arr, 1) Then
x = 1: y = j + 1: br(x, y) = arr(i, j)
Else
x = i + 1: y = j: br(x, y) = arr(i, j)
End If
End If
Next
Next
sh.[c6:j11] = br
sh.[m2] = Now() & "已调整座位！"
End Sub

复制代码

zyq75211 · 发表于 2017-10-16 16:19

谢谢老师的编译，这两天出差未及时回复，抱歉！
老师，还有个问题烦请您指点：
1、我把讲台的方向标错了，讲台在下方，这样讲台对着学生方向，C11向C6方向调整，C11向J11方向调整，也就是1列2列同时顺时针向右调整，因为1列为男生，2列为女生，12列调整到34列，依次类推，同时1排向2排调整，以此类推，你之前编译的代码是单列及讲台方向逆时针，我不会改了...
2、M4单元格内能否自动标注下，“2017年*月*日第几周调整座位”，每周五的那个日期进行调整，并做记录。这样的调整方式烦请您多多指点，谢谢老师，给您添麻烦了！

zyq75211 · 发表于 2017-10-16 16:20

ppp710715 发表于 2017-10-14 10:36

谢谢老师的编译，这两天出差未及时回复，抱歉！
老师，还有个问题烦请您指点：
1、我把讲台的方向标错了，讲台在下方，这样讲台对着学生方向，C11向C6方向调整，C11向J11方向调整，也就是1列2列同时顺时针向右调整，因为1列为男生，2列为女生，12列调整到34列，依次类推，同时1排向2排调整，以此类推，你之前编译的代码是单列及讲台方向逆时针，我不会改了...
2、M4单元格内能否自动标注下，“2017年*月*日第几周调整座位”，每周五的那个日期进行调整，并做记录。这样的调整方式烦请您多多指点，谢谢老师，给您添麻烦了！

雄鹰2013 · 发表于 2017-10-18 14:00

Sub 练习() '雄鹰2017.10.18
On Error Resume Next '列标超界
Dim arr, brr
Dim i, j, h, l
Sheets("排座").Activate
arr = Range("c6:j11")
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
n = UBound(arr): m = UBound(arr, 2)
brr(1, 1) = arr(n, m)
For j = 1 To UBound(arr, 2)
   For i = 1 To UBound(arr)
      If i < n Then h = i + 1: l = j Else h = 1: l = j + 1
      brr(h, l) = arr(i, j)
   Next i
Next j
[c6].Resize(n, m) = brr
End Sub

zyq75211 · 发表于 2017-10-18 19:57

雄鹰2013 发表于 2017-10-18 14:00
Sub 练习() '雄鹰2017.10.18
On Error Resume Next '列标超界
Dim arr, brr

谢谢老师的回复。

ppp710715 · 发表于 2017-10-19 09:10

Sub 双排顺调()
Dim x%, y%, arr, i%, j%, n%, k%, br
Dim sh As Worksheet
Set sh = Worksheets("排座")
arr = sh.[c6:j11]
ReDim br(1 To UBound(arr), 1 To UBound(arr, 2))
For j = 1 To UBound(arr, 2) Step 2
n = n + 1: k = n Mod 2
For i = 1 To UBound(arr)
If k = 1 And i = 1 Then
x = i: y = j + 2
br(x, y) = arr(i, j): br(x, y + 1) = arr(i, j + 1)
Else
If k = 1 And i > 1 Then
x = i - 1: y = j
br(x, y) = arr(i, j): br(x, y + 1) = arr(i, j + 1)
End If
End If
If k = 0 And i = UBound(arr) And j = UBound(arr, 2) - 1 Then
br(UBound(arr), 1) = arr(i, j): br(UBound(arr), 2) = arr(i, j + 1)
Else
If k = 0 And i = UBound(arr) Then
x = i: y = j + 2
br(x, y) = arr(i, j): br(x, y + 1) = arr(i, j + 1)
Else
If k = 0 And i < UBound(arr) Then
x = i + 1: y = j
br(x, y) = arr(i, j): br(x, y + 1) = arr(i, j + 1)
End If
End If
End If
Next
'Stop
Next
sh.[c6:j11] = br
sh.[m2] = Now() & "已调整座位！"
End Sub

复制代码

zhaoyunhai · 发表于 2017-10-19 09:56

VBA看不明白,以后需要好好学一下

zyq75211 · 发表于 2017-10-19 12:29

ppp710715 发表于 2017-10-19 09:10

谢谢老师的回复!
C11\D11座位顺序至C6\D6后，能否轮换到E11\F11座位上然后开始顺向轮换，这样最后一座的不会两周都在后面座？谢谢！

		自动登录	找回密码
密码			注册