ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 311|回复: 11

[求助] 排座位问题

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-6-29 09:26 | 显示全部楼层 |阅读模式
【排座位问题】求助各位大神帮忙写个VBA程序呀,问题放在下面了,数据在附件,求教!
有 62 名学生(sheet1),教室有 8 行 8列共 64 个座位( sheet2),现每月需要重新安排座位,请编写 VBA 程序,使得点击 sheet1 中的“按学号排座位”,“按身高排座位”,“随机排座位”后按要求将学生姓名填入 sheet2 的座位中。



教室排座位.zip

10.2 KB, 下载次数: 95

TA的精华主题

TA的得分主题

发表于 2020-6-29 09:53 | 显示全部楼层
Sub 身高排位()
ar = Sheet1.[a1].CurrentRegion
For i = 2 To UBound(ar)
    For s = i + 1 To UBound(ar)
        If ar(i, 3) < ar(s, 3) Then
            For j = 1 To UBound(ar, 2)
                k = ar(i, j)
                ar(i, j) = ar(s, j)
                ar(s, j) = k
            Next j
        End If
    Next s
Next i
Dim br()
ReDim br(1 To UBound(ar), 1 To 8)
For i = 2 To UBound(ar) Step 8
    n = n + 1
    y = 0
    For s = i To i + 7
        y = y + 1
        If s > UBound(ar) Then GoTo 10
        br(n, y) = ar(s, 1)
10:
    Next s
Next i
Sheet2.[d8].Resize(n, UBound(br, 2)) = br
End Sub

TA的精华主题

TA的得分主题

发表于 2020-6-29 09:57 | 显示全部楼层
Sub 学号排位()
ar = Sheet1.[a1].CurrentRegion
For i = 2 To UBound(ar)
    For s = i + 1 To UBound(ar)
        If ar(i, 2) > ar(s, 2) Then
            For j = 1 To UBound(ar, 2)
                k = ar(i, j)
                ar(i, j) = ar(s, j)
                ar(s, j) = k
            Next j
        End If
    Next s
Next i
Dim br()
ReDim br(1 To UBound(ar), 1 To 8)
For i = 2 To UBound(ar) Step 8
    n = n + 1
    y = 0
    For s = i To i + 7
        y = y + 1
        If s > UBound(ar) Then GoTo 10
        br(n, y) = ar(s, 1)
10:
    Next s
Next i
Sheet2.[m1].Resize(UBound(ar), UBound(ar, 2)) = ar
Sheet2.Range("d8:k16") = Empty
Sheet2.[d8].Resize(n, UBound(br, 2)) = br
End Sub

TA的精华主题

TA的得分主题

发表于 2020-6-29 09:59 | 显示全部楼层
  1. Sub test1()
  2.   Call test(1)
  3. End Sub
  4. Sub test2()
  5.   Call test(2)
  6. End Sub
  7. Sub test3()
  8.   Call test(3)
  9. End Sub
  10. Sub test(ByVal lx As Byte)
  11.   Dim r%, i%
  12.   Dim arr, brr(1 To 8, 1 To 8)
  13.   Randomize Timer
  14.   With Worksheets("sheet1")
  15.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  16.     Select Case lx
  17.       Case 1
  18.         .Range("a2:d" & r).Sort key1:=.Range("b2"), order1:=xlAscending, Header:=xlNo
  19.         arr = .Range("a2:d" & r)
  20.         m = 1
  21.         n = 1
  22.         For i = 1 To UBound(arr)
  23.           brr(m, n) = arr(i, 1)
  24.           n = n + 1
  25.           If n > 8 Then
  26.             m = m + 1
  27.             n = 1
  28.           End If
  29.         Next
  30.       Case 2
  31.         .Range("a2:d" & r).Sort key1:=.Range("c2"), order1:=xlAscending, Header:=xlNo
  32.         arr = .Range("a2:d" & r)
  33.         m = 1
  34.         n = 1
  35.         For i = 1 To UBound(arr)
  36.           brr(m, n) = arr(i, 1)
  37.           n = n + 1
  38.           If n > 8 Then
  39.             m = m + 1
  40.             n = 1
  41.           End If
  42.         Next
  43.       Case 3
  44.         ReDim crr(1 To r - 1, 1 To 1)
  45.         For i = 1 To UBound(crr)
  46.           crr(i, 1) = Rnd()
  47.         Next
  48.         .Range("e2").Resize(UBound(crr), 1) = crr
  49.         .Range("a2:e" & r).Sort key1:=.Range("e2"), order1:=xlAscending, Header:=xlNo
  50.         .Range("e2:e" & .Rows.Count).ClearContents
  51.         arr = .Range("a2:d" & r)
  52.         m = 1
  53.         n = 1
  54.         For i = 1 To UBound(arr)
  55.           brr(m, n) = arr(i, 1)
  56.           n = n + 1
  57.           If n > 8 Then
  58.             m = m + 1
  59.             n = 1
  60.           End If
  61.         Next
  62.     End Select
  63.   End With
  64.   With Worksheets("sheet2")
  65.     .Range("d8").Resize(UBound(brr), UBound(brr, 2)) = brr
  66.   End With
  67.             
  68. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2020-6-29 10:00 | 显示全部楼层
详见附件。

教室排座位.rar

19.99 KB, 下载次数: 27

评分

参与人数 2鲜花 +5 收起 理由
YZC51 + 3 太强大了
jx928867128 + 2 太强大了

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-6-29 10:08 | 显示全部楼层
欢迎新会员!
按学号排座位的例子见代码;
按身高排座位的例子只要把[b2]改为[c2]即可;
随机排,需要在E列加辅助列,输入公式"=rand()",把[b2]改为[e2]即可.
2020-6-29座位.png

评分

参与人数 2鲜花 +5 收起 理由
jx928867128 + 2 太强大了
YZC51 + 3

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-6-29 10:22 | 显示全部楼层
Option Explicit

Const NUM As Long = 8

Sub 学号()
  Call 排座位(2)
End Sub

Sub 身高()
  Call 排座位(3)
End Sub

Sub 随机()
  Call 排座位(4)
End Sub

Function 排座位(flag)
  Dim arr, i, j, m, n, t
  arr = Sheets("sheet1").[a1].CurrentRegion.Offset(1).Resize(, 4).Value
  ReDim brr(1 To UBound(arr, 1) / NUM + 1, 1 To NUM)
  If flag < 4 Then
    Call bsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), flag)
  Else
    Randomize
    For i = 1 To UBound(arr, 1) - 1
      n = Int(Rnd * (UBound(arr, 1) - 1)) + 1
      For j = 1 To UBound(arr, 2)
        t = arr(i, j): arr(i, j) = arr(n, j): arr(n, j) = t
      Next
    Next
  End If
  m = 1: n = 0
  For i = 1 To UBound(arr, 1) - 1
    n = n + 1: brr(m, n) = arr(i, 2) & "-" & arr(i, 1)
    If n = NUM Then m = m + 1: n = 0
  Next
  Sheets("sheet2").[d8].Resize(UBound(brr, 1), NUM) = brr
End Function

Function bsort(arr, first, last, left, right, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = first To last + first - 1 - i
      If arr(j, key) > arr(j + 1, key) Then
        For k = left To right
          t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
        Next
      End If
    Next
  Next
End Function

评分

参与人数 2鲜花 +5 收起 理由
jx928867128 + 2 太强大了
YZC51 + 3 太强大了

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-6-29 10:27 | 显示全部楼层
统一回复:感谢各位大神!我会认真看明白的,非常感谢!

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-6-29 10:33 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-6-29 10:45 | 显示全部楼层
试试看:

  1. Sub 按学号()

  2. Sheets("Sheet2").Range("D8:K16").ClearContents

  3. arr = Sheets("Sheet1").[A1].CurrentRegion

  4. Sheets("Sheet1").[AA1].Resize(UBound(arr), UBound(arr, 2)) = arr

  5. Sheets("Sheet1").Range(Sheets("Sheet1").Cells(1, 27), Sheets("Sheet1").Cells(UBound(arr), 26 + UBound(arr, 2))).Sort key1:="学号", order1:=xlAscending, Header:=xlYes

  6. m = 3
  7. n = 8
  8. For i = 2 To UBound(arr)
  9.     m = m + 1
  10.     If m > 11 Then
  11.         n = n + 1
  12.         m = 4
  13.     End If
  14.     Sheets("Sheet2").Cells(n, m) = Sheets("Sheet1").Range("AA" & i)

  15. Next

  16. Sheets("Sheet1").[AA1].CurrentRegion.ClearContents

  17. End Sub

  18. Sub 按身高()

  19. Sheets("Sheet1").Range("D8:K16").ClearContents

  20. arr = Sheets("Sheet1").[A1].CurrentRegion

  21. Sheets("Sheet1").[AA1].Resize(UBound(arr), UBound(arr, 2)) = arr

  22. Sheets("Sheet1").Range(Sheets("Sheet1").Cells(1, 27), Sheets("Sheet1").Cells(UBound(arr), 26 + UBound(arr, 2))).Sort key1:="身高", order1:=xlAscending, Header:=xlYes

  23. m = 3
  24. n = 8
  25. For i = 2 To UBound(arr)
  26.     m = m + 1
  27.     If m > 11 Then
  28.         n = n + 1
  29.         m = 4
  30.     End If
  31.     Sheets("Sheet2").Cells(n, m) = Sheets("Sheet1").Range("AA" & i)

  32. Next

  33. Sheets("Sheet1").[AA1].CurrentRegion.ClearContents

  34. End Sub

  35. Sub 随机排()

  36. Sheets("Sheet1").Range("D8:K16").ClearContents

  37. arr = Sheets("Sheet1").[A1].CurrentRegion

  38. Sheets("Sheet1").[AA1].Resize(UBound(arr), UBound(arr, 2)) = arr

  39. Cells(1, 27 + UBound(arr, 2)) = "随机"

  40. For i = 2 To UBound(arr)
  41.     Sheets("Sheet1").Cells(i, 27 + UBound(arr, 2)) = "=rand()"
  42. Next

  43. Sheets("Sheet1").Range(Sheets("Sheet1").Cells(1, 27), Sheets("Sheet1").Cells(UBound(arr), 27 + UBound(arr, 2))).Sort key1:="随机", order1:=xlAscending, Header:=xlYes

  44. m = 3
  45. n = 8
  46. For i = 2 To UBound(arr)
  47.     m = m + 1
  48.     If m > 11 Then
  49.         n = n + 1
  50.         m = 4
  51.     End If
  52.     Sheets("Sheet2").Cells(n, m) = Sheets("Sheet1").Range("AA" & i)

  53. Next

  54. Sheets("Sheet1").[AA1].CurrentRegion.ClearContents

  55. End Sub

复制代码

评分

参与人数 1鲜花 +3 收起 理由
YZC51 + 3 太强大了

查看全部评分

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2020-7-11 05:34 , Processed in 0.073474 second(s), 20 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表