6月5/6日 Excel函数实战技巧精粹 300集Office 2010微视频教程
5月7日 Excel VBA开发实战 高效办公必会的Office实战技巧
5月6日 Excel透视表实战秘技 网易云课堂-Excel数据透视表应用大全
Excel数据处理与分析实战技巧第1季
查看: 902|回复: 14

零基础12期-第十六课毕业作品作业

[复制链接]
发表于 2018-1-6 17:04:30 | 显示全部楼层 |阅读模式
最后一课了,加油........................
回复

使用道具 举报

发表于 2018-1-7 11:50:51 | 显示全部楼层
  1. Sub 寻找舞伴()
  2.     Dim area, rng, r, findV As Range, Manj, Womj, RowsC As Long
  3.     Set area = [A1].CurrentRegion
  4.     RowsC = area.Rows.Count - 1            '参会总人数
  5.     Set rng = [A2].Resize(RowsC, 1)        '参会人员名单
  6.     For Each r In rng
  7.         If r.Offset(, 1) = "男" And Range("F1").CurrentRegion.Find(r) Is Nothing Then
  8.             Cells(Manj + 3, 6) = r
  9.             Manj = Manj + 1
  10.             Set findV = [C2].Resize(RowsC, 1).Find(RowsC / 2 + 1 - r.Offset(, 2))
  11.             If findV.Offset(, -1) = "女" Then
  12.                Cells(Womj + 3, 7) = findV.Offset(, -2)
  13.             Else
  14.                Set findV = [C2].Resize(RowsC, 1).FindNext(findV)
  15.                Cells(Womj + 3, 7) = findV.Offset(, -2)
  16.             End If
  17.             Womj = Womj + 1
  18.         ElseIf r.Offset(, 1) = "女" And Range("F1").CurrentRegion.Find(r) Is Nothing Then
  19.             Cells(Womj + 3, 7) = r
  20.             Womj = Womj + 1
  21.             Set findV = [C2].Resize(RowsC, 1).Find(RowsC / 2 + 1 - r.Offset(, 2))
  22.             If findV.Offset(, -1) = "男" Then
  23.                Cells(Manj + 3, 6) = findV.Offset(, -2)
  24.             Else
  25.                Set findV = [C2].Resize(RowsC, 1).FindNext(findV)
  26.                Cells(Manj + 3, 6) = findV.Offset(, -2)
  27.             End If
  28.             Manj = Manj + 1
  29.         End If
  30.     Next
  31. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2018-1-7 19:39:57 | 显示全部楼层
  1. Sub 舞林大会()
  2. Dim i%, j%, k%, l%, m%, n%, o%, p%, q%
  3. i = (Worksheets("sheet1").Range("a1").CurrentRegion.Rows.Count - 1) / 2 + 1
  4. j = Range("a1").CurrentRegion.Rows.Count
  5. l = 3
  6.     For k = 2 To j
  7.     For m = 2 To j
  8.    
  9.         If (Range("c" & k) + Range("c" & m)) = i And Range("b" & k) <> _
  10.             Range("b" & m) Then
  11.             If Range("f1:g" & l - 1).Find(Range("a" & k)) Is Nothing Then
  12.                        If Range("b" & k) = "男" Then
  13.                         Range("f" & l) = Range("a" & k)
  14.                         Range("g" & l) = Range("a" & m)
  15.                         ElseIf Range("b" & k) = "女" Then
  16.                         Range("g" & l) = Range("a" & k)
  17.                         Range("f" & l) = Range("a" & m)
  18.                         End If
  19.                         l = l + 1
  20.                     End If
  21.         End If
  22.     Next
  23.     Next
  24. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2018-1-8 15:24:34 | 显示全部楼层
找舞伴
  1. Sub 找舞伴()
  2.     Dim i As Long, j As Long, k As Long, 找签 As Long, 男 As String, 女 As String
  3.     Dim area As Range
  4.     k = 2
  5.     Set area = Range("f3:g18")
  6.     For i = 2 To 17
  7.       
  8.    
  9.         If Cells(i, 2) = "男" Then
  10.             k = k + 1
  11.             男 = Cells(i, 1)
  12.             找签 = 9 - Cells(i, 3)
  13.             For j = 2 To 17
  14.             If Cells(j, 2) = "女" And Cells(j, 3) = 找签 Then
  15.                 女 = Cells(j, 1)
  16.             End If
  17.             Next
  18.         Else
  19.             k = k + 1
  20.             女 = Cells(i, 1)
  21.             找签 = 9 - Cells(i, 3)
  22.             For j = 2 To 17
  23.             If Cells(j, 2) = "男" And Cells(j, 3) = 找签 Then
  24.                 男 = Cells(j, 1)
  25.             End If
  26.             Next
  27.         End If
  28.         
  29.         Cells(k, "f") = 男
  30.         Cells(k, "g") = 女
  31.     Next
  32.    
  33.     area.Select
  34.     area.RemoveDuplicates Columns:=Array(1, 2), Header _
  35.         :=xlNo
复制代码


班级课表

  1. Private Sub Worksheet_Change(ByVal Target As Range)

  2.     Dim zkb As Worksheet, jxfg As Worksheet, bjkb As Worksheet
  3.     Dim i As Long, j As Long, k As Long, l As Long
  4.     Dim area As Range, kc As Range, ls As Range
  5.    
  6.     If Target.Address <> [b3].Address And Target.Address <> [c3].Address Then Exit Sub
  7.          Set area = Union(Range("d6:j11"), Range("d13:j16"), Range("d18:j23"), Range("d25:j32"))
  8.          area.ClearContents
  9.         Set zkb = Worksheets("总课表")
  10.         Set jxfg = Worksheets("教学分工")
  11.         Set bjkb = Worksheets("班级课表")
  12.         With zkb
  13.             For i = 3 To .Range("a3").CurrentRegion.Columns.Count
  14.                For k = 4 To bjkb.Range("a5").CurrentRegion.Columns.Count
  15.                     If .Cells(4, i) = [b3] And .Cells(5, i) = [c3] And .Cells(3, i) = bjkb.Cells(5, k) Then
  16.                            
  17.                         Cells(6, k) = .Cells(6, i)
  18.                         Cells(8, k) = .Cells(7, i)
  19.                         Cells(10, k) = .Cells(8, i)
  20.                         Cells(13, k) = .Cells(9, i)
  21.                         Cells(15, k) = .Cells(10, i)
  22.                         Cells(18, k) = .Cells(12, i)
  23.                         Cells(20, k) = .Cells(13, i)
  24.                         Cells(22, k) = .Cells(14, i)
  25.                         Cells(25, k) = .Cells(16, i)
  26.                         Cells(27, k) = .Cells(17, i)
  27.                         Cells(29, k) = .Cells(18, i)
  28.                         Cells(31, k) = .Cells(19, i)
  29.                     End If
  30.                     
  31.                     Next
  32.                
  33.                 Next
  34.         End With
  35.         With jxfg
  36.             For j = 2 To .Range("a2").CurrentRegion.Columns.Count
  37.                 For l = 4 To .Range("a2").CurrentRegion.Rows.Count
  38.                 If .Cells(2, j) = [b3] And .Cells(3, j) = [c3] Then
  39.                
  40.                     For Each kc In area
  41.                     If kc.Value = .Cells(l, 1) Then
  42.                         Cells(kc.Row + 1, kc.Column) = .Cells(l, j)
  43.                     End If
  44.                     Next
  45.                     
  46.                 End If
  47.                 Next
  48.             Next
  49.         End With

  50. End Sub

复制代码


个人课表——继续思考
回复 支持 反对

使用道具 举报

发表于 2018-1-8 16:42:16 | 显示全部楼层
  1. '作业,交换舞伴
  2. Sub partner()
  3.     Dim i As Long, j As Long, k As Long, l As Long, m As Long, area As Range, rng As Range
  4.     Range("f3:g14").ClearContents
  5.     j = 3
  6.     k = ([a1].CurrentRegion.Rows.Count - 1) / 2 + 1
  7.     m = [a1].CurrentRegion.Rows.Count
  8.     Set area = Range("f3:g14")
  9.     For i = 2 To m
  10.         Set rng = area.Find(Cells(i, "a"))
  11.              If rng Is Nothing Then
  12.                  If Cells(i, "b") = "男" Then
  13.                      Cells(j, "f") = Cells(i, "a")
  14.                      For l = i + 1 To m
  15.                          If Cells(l, "b") <> Cells(i, "b") And Cells(l, "c") = k - Cells(i, "c") Then
  16.                              Cells(j, "g") = Cells(l, "a")
  17.                              Exit For
  18.                          End If
  19.                      Next
  20.                      j = j + 1
  21.                  Else
  22.                      Cells(j, "g") = Cells(i, "a")
  23.                      For l = i + 1 To m
  24.                          If Cells(l, "b") <> Cells(i, "b") And Cells(l, "c") = k - Cells(i, "c") Then
  25.                              Cells(j, "f") = Cells(l, "a")
  26.                              Exit For
  27.                          End If
  28.                      Next
  29.                      j = j + 1
  30.                  End If
  31.              End If
  32.     Next
  33. End Sub
  34. '毕业设计,班级课表
  35. Private Sub Worksheet_Change(ByVal Target As Range)
  36.     Application.ScreenUpdating = False
  37.     Dim a As String, b As String, c As String
  38.     Dim i As Long, j As Long, k As Long, l As Long
  39.     Dim rng As Range, area As Range
  40.     If UCase(Target.Address(0, 0)) <> "B3" And UCase(Target.Address(0, 0)) <> "C3" Then Exit Sub
  41.     Union(Range("d6:j11"), Range("D13:j16"), Range("d18:j23"), Range("d25:j32")).ClearContents
  42.     Set area = Range("d6:j32")
  43.     a = [b3] & [c3]
  44.     j = 4
  45.     With Sheets("总课表")
  46.         For i = 3 To .[a3].CurrentRegion.Columns.Count
  47.             b = .Cells("4", i) & .Cells("5", i)
  48.             If a = b Then
  49.                 Cells(6, j) = .Cells("6", i)
  50.                 Cells(8, j) = .Cells("7", i)
  51.                 Cells(10, j) = .Cells("8", i)
  52.                 Cells(13, j) = .Cells("9", i)
  53.                 Cells(15, j) = .Cells("10", i)
  54.                 Cells(18, j) = .Cells("12", i)
  55.                 Cells(20, j) = .Cells("13", i)
  56.                 Cells(22, j) = .Cells("14", i)
  57.                 Cells(25, j) = .Cells("16", i)
  58.                 Cells(27, j) = .Cells("17", i)
  59.                 Cells(29, j) = .Cells("18", i)
  60.                 Cells(31, j) = .Cells("19", i)
  61.                 j = j + 1
  62.             End If
  63.        Next
  64.     End With
  65.     With Sheets("教学分工")
  66.        For k = 2 To .[a2].CurrentRegion.Columns.Count
  67.             c = .Cells(2, k) & .Cells(3, k)
  68.             If a = c Then
  69.                 For l = 4 To .[a2].CurrentRegion.Rows.Count
  70.                     For Each rng In area
  71.                         If rng = "政史" Then
  72.                             rng.Value = ""
  73.                         Else
  74.                             If rng = .Cells(l, "a") Then
  75.                                 rng.Offset(1, 0) = .Cells(l, k)
  76.                             End If
  77.                         End If
  78.                     Next
  79.                 Next
  80.                 Exit For
  81.             End If
  82.         Next
  83.     End With
  84.     Application.ScreenUpdating = True
  85. End Sub
  86. '毕业设计,个人课表
  87. Private Sub Worksheet_Change(ByVal Target As Range)
  88.     Application.ScreenUpdating = False
  89.     Dim i As Long, j As Long, k As Long
  90.     Dim rng As Range, area As Range
  91.     Dim KeCheng As String, a As String, b As String, c As String, d As String, e As String
  92.     If UCase(Target.Address(0, 0)) <> "B3" Then Exit Sub
  93.     Union(Range("d6:j11"), Range("D13:j16"), Range("d18:j23"), Range("d25:j32")).ClearContents '清空
  94.     Set area = Sheets("教学分工").[a1].CurrentRegion
  95.     With Sheets("总课表")
  96.     For Each rng In area '首先查找该老师是教什么课程及教哪个班级
  97.         If rng = [b3] Then
  98.             KeCheng = Sheets("教学分工").Cells(rng.Row, "a") '课程
  99.             a = Sheets("教学分工").Cells(2, rng.Column)  '年级
  100.             b = Sheets("教学分工").Cells(3, rng.Column)  '班级
  101.             For i = 4 To [a5].CurrentRegion.Columns.Count
  102.                 e = Cells("5", i) & a & b
  103.                 For j = 3 To .[a3].CurrentRegion.Columns.Count
  104.                    c = .Cells("3", j) & .Cells("4", j) & .Cells("5", j)
  105.                    If c = e Then
  106.                         For k = 6 To .[a3].CurrentRegion.Rows.Count
  107.                            If .Cells(k, j) = KeCheng Then
  108.                                d = .Cells(.Cells(k, j).Row, "b")
  109.                                If d = "" Then
  110.                                     Cells(6, i) = KeCheng
  111.                                     Cells(7, i) = a & "年" & b & "班"
  112.                                 ElseIf d = "1" Then
  113.                                     Cells(8, i) = KeCheng
  114.                                     Cells(9, i) = a & "年" & b & "班"
  115.                                 ElseIf d = "2" Then
  116.                                     Cells(10, i) = KeCheng
  117.                                     Cells(11, i) = a & "年" & b & "班"
  118.                                 ElseIf d = "3" Then
  119.                                     Cells(13, i) = KeCheng
  120.                                     Cells(14, i) = a & "年" & b & "班"
  121.                                 ElseIf d = "4" Then
  122.                                     Cells(15, i) = KeCheng
  123.                                     Cells(16, i) = a & "年" & b & "班"
  124.                                 ElseIf d = "5" Then
  125.                                     Cells(18, i) = KeCheng
  126.                                     Cells(19, i) = a & "年" & b & "班"
  127.                                 ElseIf d = "6" Then
  128.                                     Cells(20, i) = KeCheng
  129.                                     Cells(21, i) = a & "年" & b & "班"
  130.                                 ElseIf d = "7" Then
  131.                                     Cells(22, i) = KeCheng
  132.                                     Cells(23, i) = a & "年" & b & "班"
  133.                                 ElseIf d = "8" Then
  134.                                     Cells(25, i) = KeCheng
  135.                                     Cells(26, i) = a & "年" & b & "班"
  136.                                 ElseIf d = "9" Then
  137.                                     Cells(27, i) = KeCheng
  138.                                     Cells(28, i) = a & "年" & b & "班"
  139.                                 ElseIf d = "10" Then
  140.                                     Cells(29, i) = KeCheng
  141.                                     Cells(30, i) = a & "年" & b & "班"
  142.                                 Else
  143.                                     Cells(31, i) = KeCheng
  144.                                     Cells(32, i) = a & "年" & b & "班"
  145.                                 End If
  146.                            End If
  147.                         Next
  148.                     End If
  149.                 Next
  150.             Next
  151.         End If
  152.     Next
  153.     End With
  154.     Application.ScreenUpdating = True
  155. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2018-1-9 09:41:29 | 显示全部楼层
  1. Sub 寻找舞伴()
  2.     Dim i As Long, j As Long
  3.     On Error Resume Next
  4.     For i = 2 To Range("a1").CurrentRegion.Rows.Count
  5.         If Cells(i, "b") = "男" Then  'And Range(Cells(2, "f"), Cells(i, "f")).Find = 0 Then
  6.             For j = 2 To Range("a1").CurrentRegion.Count
  7.                 If Cells(j, "c") = (Range("a1").CurrentRegion.Rows.Count - 1) / 2 + 1 - Cells(i, "c") And Cells(j, "b") = "女" Then Exit For
  8.             Next
  9.             Range(Cells(2, "g"), Cells(Range("f1").CurrentRegion.Rows.Count, "g")).Find(Cells(j, "a").Value).Offset(0, -1).Value = Cells(i, "a")
  10.         End If
  11.         If Err.Number <> 0 Then
  12.             Cells(Range("f2").CurrentRegion.Rows.Count + 1, "f") = Cells(i, "a")
  13.             Err.Clear
  14.         End If
  15.         If Cells(i, "b") = "女" Then
  16.             For j = 2 To Range("a1").CurrentRegion.Count
  17.                 If Cells(j, "c") = (Range("a1").CurrentRegion.Rows.Count - 1) / 2 + 1 - Cells(i, "c") And Cells(j, "b") = "男" Then Exit For
  18.             Next
  19.             Range(Cells(2, "g"), Cells(Range("f1").CurrentRegion.Rows.Count, "f")).Find(Cells(j, "a").Value).Offset(0, 1).Value = Cells(i, "a")
  20.         End If
  21.         If Err.Number <> 0 Then
  22.             Cells(Range("f2").CurrentRegion.Rows.Count + 1, "g") = Cells(i, "a")
  23.             Err.Clear
  24.         End If
  25.     Next
  26. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2018-1-9 10:04:38 | 显示全部楼层
本帖最后由 小白兔在大草原 于 2018-1-9 10:07 编辑
  1. Private Sub Worksheet_Change(ByVal Target As Range)  '班级课表
  2.     If UCase(Target.Address(0, 0)) <> "B3" And UCase(Target.Address(0, 0)) <> "C3" Then Exit Sub
  3.     On Error Resume Next
  4.     Range("D6:J11, D13:J16, D18:J23, D25:J32").ClearContents
  5.     Dim area As Range, rng As Range, rg As Range, i As Long, j As Long
  6.     Set area = ThisWorkbook.Worksheets("总课表").Cells(6, "a").Resize(14, 2)
  7.     For j = 4 To 10
  8.         For i = 6 To 32
  9.             If Cells(i, "c") = "课程" Then
  10.                 With Sheets("总课表")
  11.                     Set rng = .Rows(3).Find(Cells(5, j))
  12.                     Set rng = rng.Offset(1, -1).Resize(1, 16).Find(Cells(3, "b"))
  13.                     Set rng = rng.Offset(1, -1).Resize(1, 6).Find(Cells(3, "c"))
  14.                     Set rg = area.Find(Cells(i, "b"))
  15.                     Cells(i, j) = .Cells(rg.Row, rng.Column)
  16.                 End With
  17.             End If
  18.         Next
  19.     Next
  20.     For i = 7 To 32
  21.         If Cells(i, "c") = "教师" Then
  22.             For j = 4 To 8
  23.                 If Cells(i - 1, j) <> "" Then
  24.                     With Worksheets("教学分工")
  25.                         Set rng = .Rows(2).Find(Cells(3, "b"))
  26.                         Set rng = rng.Offset(1, -1).Resize(1, 6).Find(Cells(3, "c"))
  27.                         Set rg = .Columns(1).Find(Cells(i - 1, j))
  28.                         Cells(i, j) = .Cells(rg.Row, rng.Column)
  29.                     End With
  30.                 End If
  31.             Next
  32.         End If
  33.     Next
  34.     If Err.Number <> 0 Then Err.Clear
  35. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2018-1-9 12:25:36 | 显示全部楼层
  1. Private Sub Worksheet_Change(ByVal Target As Range)  '个人课表
  2.     If UCase(Target.Address(0, 0)) <> "B3" Then Exit Sub
  3.     Range("D6:J11,D13:J16,D18:J23,D25:J32").ClearContents
  4.     If Cells(3, "b") = "" Then Exit Sub
  5.     Dim area As Range, rng As Range, rg As Range, i As Long, j As Long, 年级 As Long, 班级 As Long, 课程 As String, rn As Range, 节次 As String, 周几 As String, r As Range, u As Range, faddress As String
  6.     Set area = Worksheets("教学分工").Range("a2").CurrentRegion
  7.     Set r = area.Find(Cells(3, "b"), , , xlWhole)
  8.     Set u = r
  9.     If Not r Is Nothing Then
  10.         faddress = r.Address
  11.     Do
  12.         Set r = area.FindNext(r)
  13.         If r.Address <> faddress Then
  14.             Set u = Union(u, r)
  15.         Else
  16.             Exit Do
  17.         End If
  18.     Loop Until r.Address = faddress
  19.         For Each rng In u
  20.             With Worksheets("教学分工")
  21.                 年级 = .Cells(2, rng.Column)
  22.                 班级 = .Cells(3, rng.Column)
  23.                 课程 = .Cells(rng.Row, 1)
  24.             End With
  25.             With Worksheets("总课表")
  26.                 For j = 3 To .Range("a3").CurrentRegion.Columns.Count
  27.                     If .Cells(4, j) = 年级 And .Cells(5, j) = 班级 Then
  28.                         For i = 6 To 19
  29.                             If .Cells(i, j) = 课程 Then
  30.                                 周几 = .Cells(3, j)
  31.                                 If .Cells(i, "b") <> "" Then
  32.                                     节次 = .Cells(i, "b")
  33.                                 ElseIf .Cells(i, "b") = "" Then
  34.                                     节次 = "早自习"
  35.                                 End If
  36.                                 Set rn = Cells(Columns(2).Find(节次).Row, Rows(5).Find(周几).Column)
  37.                                 rn = 课程
  38.                                 rn.Offset(1, 0) = 年级 & "年" & 班级 & "班"
  39.                             End If
  40.                         Next
  41.                         
  42.                     End If
  43.                 Next
  44.             End With
  45.         Next
  46.     End If
  47. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2018-1-10 14:51:58 | 显示全部楼层
我是民航骄子!!!

  1. Option Explicit

  2. Sub jiaohuanwuban()

  3.     Dim i As Long, rng As Range, area As Range, rng_find As Range
  4.    
  5.    
  6.     'x,y用来记录男女人数的位置
  7.     Dim x As Long, y As Long
  8.     x = 3
  9.     y = 3
  10.    
  11.     'j用来进行匹配
  12.     Dim j As Long
  13.    
  14.    
  15.    
  16.     For i = 2 To 17
  17.         
  18.         Set area = Worksheets("sheet1").Range(Columns(6), Columns(7))
  19.         
  20.    
  21.         Set rng = Cells(i, 1)
  22.         
  23.         Set rng_find = area.Find(rng.Value)
  24.         
  25.         If rng_find Is Nothing Then
  26.         
  27.             Select Case rng.Offset(0, 1).Value
  28.             Case "男"
  29.                 Cells(x, 6).Value = rng.Value
  30.                 x = x + 1
  31.                 '找出对应的女伴
  32.                 For j = i To 17
  33.                
  34.                     If Cells(j, 3) = 9 - rng.Offset(0, 2).Value And Cells(j, 2) = "女" Then
  35.                     
  36.                         Cells(y, 7).Value = Cells(j, 3).Offset(0, -2).Value
  37.                         y = y + 1
  38.                         Exit For
  39.                         
  40.                     End If
  41.                     
  42.                 Next
  43.                
  44.             Case "女"
  45.                 Cells(y, 7).Value = rng.Value
  46.                 y = y + 1
  47.                 '找出对应的男伴
  48.                 For j = i To 17
  49.                
  50.                     If Cells(j, 3) = 9 - rng.Offset(0, 2).Value And Cells(j, 2) = "男" Then
  51.                     
  52.                         Cells(x, 6).Value = Cells(j, 3).Offset(0, -2).Value
  53.                         x = x + 1
  54.                         Exit For
  55.                     End If
  56.                     
  57.                 Next
  58.                
  59.             End Select
  60.         
  61.         
  62.         End If
  63.         
  64.         
  65.         
  66.         
  67.    
  68.     Next
  69.    



  70. End Sub
复制代码







下面是毕业设计,分两部分,都是写在worksheets里的(不是写在模块里的)
首先是班级课表
  1. Option Explicit

  2. Private Sub Worksheet_Change(ByVal Target As Range)

  3.     If UCase(Target.Address(0, 0)) = "B3" Or UCase(Target.Address(0, 0)) = "C3" Then
  4.    
  5.         Dim grade As Long, class As Long
  6.         
  7.         grade = Range("B3").Value
  8.         
  9.         class = Range("C3").Value
  10.         
  11.         Application.EnableEvents = False
  12.         
  13.         Call zhaokecheng(grade, class)
  14.         Call zhaolaoshi(grade, class)
  15.         
  16.         Application.EnableEvents = True
  17.         
  18.         
  19.         
  20.         
  21.    
  22.    
  23.     End If
  24.    
  25. End Sub


  26. Sub zhaokecheng(ByVal grade As Long, ByVal class As Long)

  27.     Dim i As Long 'i表示星期
  28.     Dim j As Long 'j表示课程
  29.     Dim k As Long 'k表示班级课表中的课程
  30.     With Worksheets("总课表")
  31.     For i = 1 To 5
  32.         For j = 1 To 14
  33.             Select Case j
  34.                 Case 6, 10
  35.                 Case Else
  36.                     .Cells(5 + j, 2 + 15 * (i - 1) + 5 * (grade - 7) + class).Copy Cells(6 + k, 3 + i)
  37.                     k = k + 2
  38.                     If k = 6 Or k = 11 Or k = 18 Then k = k + 1
  39.             End Select
  40.         Next
  41.         k = 0
  42.     Next
  43.     End With


  44. End Sub



  45. Sub zhaolaoshi(ByVal grade As Long, ByVal class As Long)
  46.    
  47.     Dim rng As Range
  48.     Dim area As Range
  49.    
  50.     Dim i As Long ' i代表日期
  51.     Dim j As Long ' j代表每天的课
  52.    
  53.     With Worksheets("教学分工")
  54.         Set area = .Range("a4:a20")
  55.         For i = 1 To 5
  56.             For j = 1 To 27 Step 2
  57.                 If j = 7 Or j = 12 Or j = 19 Then j = j + 1
  58.                 Set rng = area.Find(Cells(5 + j, 3 + i).Value)
  59.                 If Not rng Is Nothing Then
  60.                 .Range(rng.Address(0, 0)).Offset(0, 5 * (grade - 7) + class).Copy Cells(6 + j, i + 3)
  61.                 End If
  62.             Next
  63.         Next
  64.     End With
  65. End Sub
复制代码



其次是个人课表
  1. Option Explicit



  2. Sub 个人课表()
  3.     Range("d6:j11").ClearContents
  4.     Range("d13:j16").ClearContents
  5.     Range("d18:j23").ClearContents
  6.     Range("d25:j32").ClearContents
  7.    
  8.    
  9.     Dim str As String
  10.    
  11.     str = Range("b3").Value
  12.    
  13.    
  14.     Dim area As Range
  15.     Set area = Worksheets("教学分工").UsedRange
  16.    
  17.    
  18.     Dim rng As Range
  19.    
  20.     '===========寻找班级、年级、课程类别
  21.    
  22.     Set rng = area.Find(str)
  23.    
  24.     If Not rng Is Nothing Then
  25.    
  26.     Dim faddress As String
  27.    
  28.     faddress = rng.Address
  29.    
  30.     Do
  31.    
  32.     Dim grade As Long
  33.     Dim class As Long
  34.     Dim subject As String
  35.    
  36.     grade = Worksheets("教学分工").Cells(2, rng.Column)
  37.     class = Worksheets("教学分工").Cells(3, rng.Column)
  38.     subject = Worksheets("教学分工").Cells(rng.Row, 1)
  39.    
  40.    
  41.     '================寻找星期,第几节课
  42.    
  43.     With Worksheets("总课表")
  44.    
  45.         Dim i As Long 'i代表第几星期
  46.         Dim j As String 'j代表第几节课
  47.         
  48.         Dim rng2 As Range
  49.         
  50.         For i = 1 To 5
  51.         
  52.         Dim area_morning As Range
  53.         Dim area_afternoon As Range
  54.         Dim area_evening As Range
  55.         
  56.         Dim area_day As Range
  57.         
  58.         Set area_morning = .Range(.Cells(6, 2 + 15 * (i - 1) + class + 5 * (grade - 7)), .Cells(10, 2 + 15 * (i - 1) + class + 5 * (grade - 7)))
  59.         Set area_afternoon = .Range(.Cells(12, 2 + 15 * (i - 1) + class + 5 * (grade - 7)), .Cells(14, 2 + 15 * (i - 1) + class + 5 * (grade - 7)))
  60.         Set area_evening = .Range(.Cells(16, 2 + 15 * (i - 1) + class + 5 * (grade - 7)), .Cells(19, 2 + 15 * (i - 1) + class + 5 * (grade - 7)))
  61.         
  62.         Set area_day = Union(area_morning, area_afternoon, area_evening)
  63.         
  64.         For Each rng2 In area_day
  65.             If rng2.Value = subject Then
  66.                
  67.                 j = .Cells(rng2.Row, 2).Value
  68.                
  69.                
  70.                 Select Case j
  71.                 Case "", "1", "2"
  72.                     rng2.Copy Cells(6 + 2 * Val(j), 3 + i) '课程
  73.                     Cells(7 + 2 * Val(j), 3 + i).Value = grade & "年级" & class & "班" '班级
  74.                
  75.                 Case "3", "4"
  76.                     rng2.Copy Cells(7 + 2 * Val(j), 3 + i) '课程
  77.                     Cells(8 + 2 * Val(j), 3 + i).Value = grade & "年级" & class & "班" '班级
  78.                
  79.                 Case "5", "6", "7"
  80.                     rng2.Copy Cells(8 + 2 * Val(j), 3 + i) '课程
  81.                     Cells(9 + 2 * Val(j), 3 + i).Value = grade & "年级" & class & "班" '班级
  82.                   
  83.                 Case "8", "9", "10", "11"
  84.                     rng2.Copy Cells(9 + 2 * Val(j), 3 + i) '课程
  85.                     Cells(10 + 2 * Val(j), 3 + i).Value = grade & "年级" & class & "班" '班级
  86.                
  87.                 End Select
  88.             
  89.             End If
  90.         
  91.         Next
  92.         Next
  93.         
  94.    
  95.     End With
  96.    
  97.     Set rng = area.FindNext(rng)
  98.    
  99.     Loop Until rng.Address = faddress
  100.    
  101.    
  102. End If

  103. End Sub

复制代码
回复 支持 反对

使用道具 举报

发表于 2018-1-18 13:30:20 | 显示全部楼层
本帖最后由 sydi56 于 2018-1-18 13:31 编辑
  1. sub 交换舞伴()

  2.     Dim pair As Long               '舞伴的对数
  3.     Dim sumv As Long               '配对的签数合计值
  4.     Dim area As Range              '记录备选名单的区域
  5.     Dim name As String             '记录备选名单的候选人姓名
  6.     Dim i As Long, m As Long       '记录备选名单的行数、总行数
  7.     Dim j As Long, n As Long       '记录答题区的行数、总行数
  8.     Dim goal_rng As Range          '记录答题区的单元格信息
  9.     Dim sex As String              '记录备选名单的候选人性别
  10.     Dim num As Long                '记录备选名单的候选人签数
  11.     Dim flag_rng As Range          '记录备选区所选标签的单元格信息
  12.     Dim num_row As Long            '记录备选区中所配对的行号
  13.    
  14.     Range("F3:G14").ClearContents
  15.    
  16.     pair = InputBox("请输入此次舞会需要配对的对数:(6-12对之间)")
  17.    
  18.     If pair < 6 Or pair > 12 Then                                 '对舞伴对数不符合要求的错误处理
  19.         MsgBox "对数越界,请输入6-12对之间。"
  20.         Exit Sub
  21.     End If
  22.    
  23.     sumv = pair + 1
  24.     Set area = Range("a1").CurrentRegion
  25.     i = 2
  26.     j = 3
  27.     m = area.Rows.Count
  28.     n = pair
  29.    
  30.     If Cells(i, 2) = "男" Then                                   '在答题区填写第一个舞伴信息
  31.         Cells(j, 6) = Cells(i, 1)
  32.     Else
  33.         Cells(j, 7) = Cells(i, 1)
  34.     End If
  35.    
  36.     Do
  37.             
  38.             sex = Cells(i, 2)
  39.             num = sumv - Cells(i, 3)
  40.             Set flag_rng = area.Find(num, MatchCase:=False)     'mathcase:=false是精确匹配
  41.             
  42.             If Not flag_rng Is Nothing Then
  43.                 num_row = flag_rng.Row
  44.                 If Cells(num_row, 2) = sex Then Set flag_rng = area.FindNext(flag_rng)
  45.                 num_row = flag_rng.Row
  46.             Else
  47.                 MsgBox "没有配对的标签,标签计数有问题!"
  48.                 Exit Sub
  49.             End If
  50.             
  51.             name = Cells(num_row, 1)
  52.             sex = Cells(num_row, 2)
  53.             
  54.             Select Case sex
  55.                 Case "男"
  56.                     Cells(j, 6) = name
  57.                 Case "女"
  58.                     Cells(j, 7) = name
  59.             End Select
  60.             
  61.             Do
  62.                 i = i + 1
  63.                 name = Cells(i, 1)
  64.                 num = Cells(i, 3)
  65.                 Debug.Print name
  66.                 Debug.Print num
  67.                 Set goal_rng = Range("F3:G14").Find(name, MatchCase:=False)
  68.                 If goal_rng Is Nothing And num <= pair Then Exit Do
  69.             Loop While i <= m
  70.             
  71.             sex = Cells(i, 2)
  72.             j = j + 1
  73.             
  74.             If j > n + 2 Then Exit Sub
  75.             
  76.             Select Case sex
  77.                 Case "男"
  78.                     Cells(j, 6) = name
  79.                 Case "女"
  80.                     Cells(j, 7) = name
  81.             End Select
  82.             
  83.     Loop While j <= n + 2
  84.    
  85. End Sub
复制代码
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 入学

本版积分规则

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