11月13/14日 零基础学Excel VBA 300集Office 2010微视频教程
10月18/19日 7天Excel脱白 高效办公必会的Office实战技巧
10月23/24日 财务会计玩转Excel 网易云课堂-Excel数据透视表应用大全
Excel数据处理与分析实战技巧第1季
查看: 388|回复: 14

零基础学ExcelVBA 第十一期 第十五课时作业贴

[复制链接]
发表于 2017-8-12 10:26:08 | 显示全部楼层 |阅读模式
本帖最后由 开心妙妙 于 2017-9-6 19:50 编辑

踊跃交作业哈加油最后一课了

回复

使用道具 举报

发表于 2017-8-12 13:50:15 | 显示全部楼层
本帖最后由 cynthiashi 于 2017-8-16 07:08 编辑

Function BadSum(str As String) As Long '8月11号作业1从字符串自动提取数字然后求和

    Dim i&, j&
    Dim num
    i = 1
    Do While i <= Len(str)
        num = 0
        If Mid(str, i, 1) Like "[0-9]" Then
            num = Mid(str, i, 1)
            j = i + 1
            Do While j <= Len(str)
                num = num & Mid(str, j, 1)
                If Not IsNumeric(num) Then
                    j = Len(str) + 1
                    num = Val(num)
                Else
                    j = j + 1
                End If
            Loop
        End If
        BadSum = BadSum + num
        i = i + Len(num)
    Loop
   
End Function



Sub FindDpartner() '8月11号作业2武林大会之交换舞伴

    Dim i&, j&, xrow&, num&
    Dim rng As Range
    num = [a1].CurrentRegion.Rows.Count
    Range("f3:g14").ClearContents
    For i = 2 To num
        Set rng = [f1].CurrentRegion.Find(Cells(i, "a").Value)
        If rng Is Nothing Then
            xrow = [f1].CurrentRegion.Rows.Count + 1
            If Cells(i, "b") = "男" Then
                Cells(xrow, "f") = Cells(i, "a")
            Else
                Cells(xrow, "g") = Cells(i, "a")
            End If
            For j = i + 1 To num
                If Cells(j, "b") <> Cells(i, "b") And Cells(j, "c") + Cells(i, "c") = (num - 1) / 2 + 1 Then
                    If Cells(i, "b") = "男" Then
                        Cells(xrow, "g") = Cells(j, "a")
                    Else
                        Cells(xrow, "f") = Cells(j, "a")
                    End If
                End If
            Next
        End If
    Next

End Sub



Private Sub Worksheet_Change(ByVal Target As Range) '8月11号作业3毕业设计课程表之"班级课表"

    Dim topic As Range
    Dim firstadd As String
    Dim i&, j&, xcol&, xrow&
    Application.ScreenUpdating = False
    If Target.Address <> [b3].Address And Target.Address <> [c3].Address Then Exit Sub
    Union(Range("d6:j11"), Range("d13:j16"), Range("d18:j23"), Range("d25:j32")).ClearContents
    With Worksheets("总课表")
        For i = 4 To [a5].CurrentRegion.Columns.Count
            For j = 3 To .[a3].CurrentRegion.Columns.Count
                If .Cells(4, j) = [b3] And .Cells(5, j) = [c3] And .Cells(3, j) = Cells(5, i) Then
                    Cells(6, i) = .Cells(6, j)
                    Cells(8, i) = .Cells(7, j)
                    Cells(10, i) = .Cells(8, j)
                    Cells(13, i) = .Cells(9, j)
                    Cells(15, i) = .Cells(10, j)
                    Cells(18, i) = .Cells(12, j)
                    Cells(20, i) = .Cells(13, j)
                    Cells(22, i) = .Cells(14, j)
                    Cells(25, i) = .Cells(16, j)
                    Cells(27, i) = .Cells(17, j)
                    Cells(29, i) = .Cells(18, j)
                    Cells(31, i) = .Cells(19, j)
                End If
            Next
        Next
    End With
    With Worksheets("教学分工")
        For xcol = 2 To .[a1].CurrentRegion.Columns.Count
           If .Cells(2, xcol) = [b3] And .Cells(3, xcol) = [c3] Then
               xcol = xcol
               Exit For
           End If
        Next
        For xrow = 4 To .[a1].CurrentRegion.Rows.Count
            Set area = [a5].CurrentRegion
            For Each topic In area
                If topic.Value = .Cells(xrow, "a") Then
                    Cells(topic.Row + 1, topic.Column) = .Cells(xrow, xcol)
                End If
            Next
        Next
    End With
    Application.ScreenUpdating = True
   
End Sub



Private Sub Worksheet_Change(ByVal Target As Range) '8月11号作业3毕业设计课程表之"个人课表"

    Dim i&, j&, xrow&, xcol&, firstadd As String
    Dim grade As Range, class As Range, topic As Range
    Dim name As Range, num As Range, area As Range, ref As Range
    Application.ScreenUpdating = False
    If Target.Address <> [b3].Address Then Exit Sub
    Union(Range("d6:j11"), Range("d13:j16"), Range("d18:j23"), Range("d25:j32")).ClearContents
    For Each name In Worksheets("教学分工").[a1].CurrentRegion
        If name = [b3] Then
            Set grade = Worksheets("教学分工").Cells(2, name.Column)
            Set class = Worksheets("教学分工").Cells(3, name.Column)
            Set topic = Worksheets("教学分工").Cells(name.Row, "A")
                For i = 4 To [a5].CurrentRegion.Columns.Count
                    With Worksheets("总课表")
                        For j = 3 To .[a3].CurrentRegion.Columns.Count
                            If Cells(5, i) = .Cells(3, j) And grade = .Cells(4, j) And class = .Cells(5, j) Then
                            xcol = j
                            For Each num In .[a3].CurrentRegion
                                If num.Value = topic.Value And num.Column = xcol Then
                                    Set ref = .[a3].CurrentRegion.Cells(num.Row, "B")
                                    Select Case ref
                                    Case 0
                                        Cells(6, i) = topic
                                        Cells(7, i) = grade & "0" & class 'grade年级class班别
                                    Case 1
                                        Cells(8, i) = topic
                                        Cells(9, i) = grade & "0" & class
                                    Case 2
                                        Cells(10, i) = topic
                                        Cells(11, i) = grade & "0" & class
                                    Case 3
                                        Cells(13, i) = topic
                                        Cells(14, i) = grade & "0" & class
                                    Case 4
                                        Cells(15, i) = topic
                                        Cells(16, i) = grade & "0" & class
                                    Case 5
                                        Cells(18, i) = topic
                                        Cells(19, i) = grade & "0" & class
                                    Case 6
                                        Cells(20, i) = topic
                                        Cells(21, i) = grade & "0" & class
                                    Case 7
                                        Cells(22, i) = topic
                                        Cells(23, i) = grade & "0" & class
                                    Case 8
                                        Cells(25, i) = topic
                                        Cells(26, i) = grade & "0" & class
                                    Case 9
                                        Cells(27, i) = topic
                                        Cells(28, i) = grade & "0" & class
                                    Case 10
                                        Cells(29, i) = topic
                                        Cells(30, i) = grade & "0" & class
                                    Case 11
                                        Cells(31, i) = topic
                                        Cells(32, i) = grade & "0" & class
                                    End Select
                                End If
                            Next
                        End If
                    Next
                End With
            Next
        End If
    Next
    Application.ScreenUpdating = True
End Sub


回复 支持 反对

使用道具 举报

发表于 2017-8-12 22:23:59 | 显示全部楼层
本帖最后由 CNNNOO 于 2017-8-13 08:37 编辑
  1. Function strsum(ByVal sstr As Range)
  2.     'CNN第十五课时作业题1从字符串中取数求和
  3.     '本函数主要处理求和
  4.     Dim rng As Range        
  5.     Dim numsum As Long
  6.     Dim numcount As Long
  7.     Dim numlen As Long
  8.     Dim numadd As Long
  9.     Dim datastr As String
  10.     Dim newstr As String
  11.     Dim i As Long
  12.     Set rng = sstr
  13.     datastr = rng.Value
  14.     numlen = Len(datastr)
  15.     i = 1
  16.     If rng.Count > 1 Then
  17.         strsum = "请选择目标单元格!"
  18.     Else
  19.         Do
  20.             If Mid(datastr, i, 1) Like "[0-9]" = True Then
  21.                 If i - numadd = 1 Then
  22.                     numlen = Len(datastr) - i
  23.                     numadd = i
  24.                 Else
  25.                     numcount = numcount + 1
  26.                     numlen = Len(datastr) - i
  27.                     numadd = i
  28.                     newstr = Right(datastr, numlen + 1)
  29.                     numsum = mnum(Mid(datastr, i, 1), newstr) + numsum
  30.                 End If
  31.             End If
  32.             numlen = Len(datastr) - i
  33.             i = i + 1            
  34.         Loop Until numlen = 0
  35.     End If
  36.     strsum = numsum
  37. End Function
  38. Function mnum(ByVal isnum As String, newstr As String)
  39.     '将数字提取出来并返回计数函数
  40.     Dim n As Long
  41.     Dim num As Long
  42.     Dim numstr As String
  43.     Dim nchr As Boolean
  44.     numstr = ""
  45.     For n = 1 To Len(newstr)
  46.         nchr = IsNumeric(Mid(newstr, 1, n))
  47.         If nchr = -1 Then
  48.             numstr = Mid(newstr, 1, n)
  49.         End If
  50.     Next
  51.     num = Val(numstr)
  52.     mnum = num
  53. End Function
复制代码
  1. Sub CNN第十五课时作业题2武林大会之交换舞伴()
  2.     Dim rng As Range
  3.     Dim orng As Range
  4.     Dim irng As Range
  5.     Dim area As Range
  6.     Dim 配对值 As Long
  7.     Dim 签数 As Range
  8.     Dim 备选女签 As Long
  9.     Dim 备选男签 As Long
  10.     Dim 男伴位置 As Long
  11.     Dim 女伴位置 As Long
  12.     Dim 男签 As Long
  13.     Dim 女签 As Long
  14.     Dim 性别 As Range
  15.     Dim 男伴 As String
  16.     Dim 女伴 As String
  17.     Dim i As Long
  18.     i = 3
  19.     Set area = Range("A1").CurrentRegion
  20.     Set 性别 = area.Offset(1, 1).Resize(area.Rows.Count - 1, 1)
  21.     Set 签数 = area.Offset(1, 2).Resize(area.Rows.Count - 1, 1)
  22.     Range("F3:G100").ClearContents
  23.     For Each rng In 签数        
  24.         If rng.Value > 配对值 Then
  25.             配对值 = rng.Value
  26.         End If
  27.     Next
  28.     配对值 = 配对值 + 1
  29.     For Each orng In 性别        
  30.         If orng.Value = Range("F2") Then
  31.             男伴 = orng.Offset(0, -1).Value
  32.             男签 = orng.Offset(0, 1).Value
  33.             备选女签 = 配对值 - 男签
  34.             男伴位置 = orng.Row            
  35.             For Each irng In 性别.Offset(男伴位置 - 1, 0)
  36.                 If irng.Value = Range("g2") Then
  37.                     女签 = irng.Offset(0, 1).Value
  38.                     If 女签 = 备选女签 Then
  39.                         女伴 = irng.Offset(0, -1).Value
  40.                         女签 = irng.Offset(0, 1).Value
  41.                         女伴位置 = irng.Row                        
  42.                         Range("F" & i) = 男伴
  43.                         Range("g" & i) = 女伴
  44.                         i = i + 1
  45.                     End If
  46.                 End If
  47.             Next
  48.         Else
  49.             女伴 = orng.Offset(0, -1).Value
  50.             女签 = orng.Offset(0, 1).Value
  51.             备选男签 = 配对值 - 女签
  52.             女伴位置 = orng.Row            
  53.             For Each irng In 性别.Offset(女伴位置 - 1, 0)
  54.                 If irng.Value = Range("f2") Then
  55.                     男签 = irng.Offset(0, 1).Value
  56.                     If 男签 = 备选男签 Then
  57.                         男伴 = irng.Offset(0, -1).Value
  58.                         男签 = irng.Offset(0, 1).Value
  59.                         男伴位置 = irng.Row                        
  60.                         Range("g" & i) = 女伴
  61.                         Range("F" & i) = 男伴
  62.                         i = i + 1
  63.                     End If
  64.                 End If
  65.             Next
  66.         End If
  67.     Next
  68. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2017-8-14 23:33:13 | 显示全部楼层
  1. Option Explicit
  2. '我想从【不良明细】这一列中提取里面的不良数量,然后自动求和到【不良总数】里
  3. '
  4. '比如:F3中的23我不想自己算出来,而是根据后面【不良明细】中自动求出来,
  5. '而不良明细中多少不定,项目不定。

  6. Sub 提取数字计算()
  7.     Dim i&, j&, m&, num&
  8.     For i = 3 To [g2].CurrentRegion.Rows.Count + 1 '纵向循环和变量
  9.         num = 0
  10.         For j = 1 To Len(Range("g" & i))    '横向循环设定和变量值域
  11.             
  12.             For m = Len(Range("g" & i)) - i To 1 Step -1  '数字宽度循环和变量
  13.               
  14.               If IsNumeric(Mid(Range("g" & i), j, m)) Then
  15.                
  16.                 num = num + Mid(Range("g" & i), j, m) '出现数字时,将其赋值给num
  17.                
  18.                 j = j + m                      '让变量j跳过本次所取数值的宽度(位数)
  19.                
  20.                 Exit For    '已经取到本位置最大值后,为防止取出小一级的数值,跳出本位置循环
  21.               
  22.               End If
  23.               
  24.             Next
  25.             
  26.         Next
  27.         Range("f" & i) = num    '赋值给相关单元格
  28.     Next

  29. End Sub



  30. '题目
  31. '  若干对舞伴(6-12对不定)一起举行一个小型舞会,会上有人提议:以抽签方式确定舞伴的配对。
  32. '令男女分组抽签 , 抽到签后按下述规则进行配对:
  33. '  若某对男女抽签的签数之和等于参会舞伴对数加1 , 则就是这次舞会的舞伴
  34. '现各人抽的的签如C2:C24所示,问配对情况.

  35. Sub 舞林大会配对()
  36.     Dim i&, j&, n&, num&, 对数&
  37.     Application.ScreenUpdating = False
  38.     对数 = 8
  39.     For i = 2 To 25
  40.    
  41.         If Cells(i, 2) = "男" Then  '当单元格为男时
  42.            
  43.             j = Cells(Rows.Count, 6).End(xlUp).Row + 1      '值区域的第一个空行行号
  44.             Cells(j, 6) = Cells(i, 1)   '将cells(i,1)的值写入cells(j,6)
  45.             num = 对数 + 1 - Cells(i, 3)    '对应舞伴的号码
  46.             
  47.             For n = 1 To 25             '在整个表里找符合条件的行
  48.                 If Cells(n, 3) = num And Cells(n, 2) = "女" Then
  49.                     Cells(j, 7) = Cells(n, 1)   '凡符合的都写入相应单元格
  50.                 End If
  51.             Next
  52.         
  53.         ElseIf Cells(i, 2) = "女" Then  '当单元格为女时
  54.             
  55.             j = Cells(Rows.Count, 7).End(xlUp).Row + 1
  56.             Cells(j, 7) = Cells(i, 1)
  57.             num = 对数 + 1 - Cells(i, 3)
  58.             
  59.             For n = 1 To 25
  60.                 If Cells(n, 3) = num And Cells(n, 2) = "男" Then
  61.                     Cells(j, 6) = Cells(n, 1)
  62.                 End If
  63.             Next
  64.         End If
  65.       
  66.     Next
  67.    
  68.     Range("$F$1:$G$99").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
  69.                         '删除重复项
  70.     [f2].CurrentRegion.Interior.ColorIndex = [f2].Interior.ColorIndex
  71.                         '恢复部分操作损失底色单元格
  72.     Application.ScreenUpdating = True
  73. End Sub

复制代码


回复 支持 反对

使用道具 举报

发表于 2017-8-16 22:32:46 | 显示全部楼层
  1. 奔跑的夜

  2. '作业1 计算不良总数
  3. Sub 不良总数()
  4.     Dim str As String, sumN As Long, i As Long, j As Long, m As Long
  5.     j = 2
  6.     For m = 3 To Range("f2").CurrentRegion.Rows.Count + 1
  7.     str = Range("g" & m)
  8.         For i = 1 To Len(str)
  9.             If Mid(str, i, 1) Like "#" Then
  10.                 sumN = sumN + 几位数字(i, str, j)
  11.                 i = i + j
  12.             Else
  13.             End If
  14.         Next
  15.     Range("f" & m) = sumN
  16.     sumN = 0
  17.     Next

  18. End Sub

  19. Function 几位数字(ByVal i As Long, ByVal str As String, ByVal j As Long)
  20.     Do Until IsNumeric(Mid(str, i, j)) = False
  21.         If IsNumeric(Mid(str, i, j)) Then
  22.             j = j + 1
  23.         Else
  24.         End If
  25.     Loop
  26.         几位数字 = Mid(str, i, j - 1)
  27. End Function
复制代码
  1. '作业2 武林大会之交换舞伴
  2. Sub 武林大会之交换舞伴()
  3.     Dim sumP As Long, i As Long, j As Long, number As Long, 性别 As String
  4.     Dim m As Long
  5.     Range("f3", "g" & Range("f3").CurrentRegion.Rows.Count).ClearComments
  6.     m = 3
  7.     sumP = ([a1].CurrentRegion.Rows.Count - 1) \ 2 + 1
  8.     For i = 2 To [a1].CurrentRegion.Rows.Count
  9.         number = Range("c" & i)
  10.         性别 = Range("b" & i)
  11.         For j = i + 1 To [a1].CurrentRegion.Rows.Count
  12.             If Range("b" & j) <> 性别 Then
  13.                 If sumP = Range("c" & i) + Range("c" & j) Then
  14.                     If "男" = 性别 Then
  15.                         Range("f" & m) = Range("a" & i)
  16.                         Range("g" & m) = Range("a" & j)
  17.                     Else
  18.                         Range("g" & m) = Range("a" & i)
  19.                         Range("f" & m) = Range("a" & j)
  20.                     End If
  21.                     m = m + 1
  22.                 End If
  23.             End If
  24.         Next
  25.     Next
  26. End Sub
复制代码


回复 支持 反对

使用道具 举报

发表于 2017-8-17 06:11:14 | 显示全部楼层
本帖最后由 yiqian11 于 2017-8-20 23:48 编辑
  1. Option Explicit

  2. '作业1
  3. Function statistics(ByVal rng As String)
  4.     Application.Volatile True
  5.     Dim i As Long, str As String, sum As Long
  6.     For i = 1 To Len(rng)
  7.         str = ""
  8.         Do Until Mid(rng, i, 1) Like "[!0-9]"
  9.             str = str & Mid(rng, i, 1)
  10.             i = i + 1
  11.         Loop
  12.             sum = sum + Val(str)
  13.     Next
  14.     statistics = sum
  15. End Function

  16. '作业2
  17. Sub match()
  18.     Dim i As Long, num As Long, firstadd As String, rng As Range
  19.     [F1].CurrentRegion.Offset(2).ClearContents
  20.     For i = 2 To Range("a1").CurrentRegion.Rows.Count - 1
  21.         num = 9 - Cells(i, 1).Offset(0, 2).Value
  22.         Set rng = Range("a1").CurrentRegion.Find(num)
  23.         If Not rng Is Nothing Then
  24.             firstadd = rng.Address
  25.             Do
  26.                 If rng.Offset(0, -1) <> Cells(i, 1).Offset(0, 1) Then
  27.                     If Range("f1").CurrentRegion.Find(Cells(i, 1)) Is Nothing Then
  28.                         [F1].End(xlDown).Offset(1) = IIf(Cells(i, 1).Offset(0, 1) = "男", Cells(i, 1), rng.Offset(, -2))
  29.                         [F1].End(xlDown).Offset(, 1) = IIf(Cells(i, 1).Offset(0, 1) = "女", Cells(i, 1), rng.Offset(, -2))
  30.                     End If
  31.                     Exit Do
  32.                 End If
  33.                 Set rng = Range("a1").CurrentRegion.FindNext(rng)
  34.             Loop Until rng.Address = firstadd
  35.         End If
  36.     Next
  37. End Sub


  38. '毕业设计
  39. '班级课表
  40. Private Sub Worksheet_Change(ByVal Target As Range)
  41.     If Intersect([B3:C3], Target) Is Nothing Then Exit Sub
  42.     Call grade
  43. End Sub
  44. Sub grade()
  45.         Dim grade As Long, class As Long
  46.         Dim totalsecarea As Range, tsec As Range, secarea As Range, sec As Range, totalweekarea As Range, twk As Range, weekarea As Range, wk As Range
  47.         Dim teacher As String, firstadd As String, course As String
  48.         On Error Resume Next
  49.       
  50.         With Sheets("班级课表")
  51.             .[D6:J11,D13:J16,D18:J23,D25:J32].ClearContents
  52.             grade = .[B3]
  53.             class = .[C3]
  54.             Set secarea = Range(.[B6], .Range("b" & Rows.Count).End(xlUp).Offset(1))
  55.             Set weekarea = Range(.[D5], .[H5])
  56.         End With
  57.         With Sheets("总课表")
  58.             Set totalsecarea = Range(.[A6], .[B19])
  59.             Set totalweekarea = Range(.[C3].Offset(0, -1), .[C3].End(xlToRight))
  60.             For Each wk In weekarea
  61.                 Set twk = totalweekarea.Find(wk.Value)
  62.                 If Not twk Is Nothing Then firstadd = twk.Address
  63.                 Do
  64.                 If twk.Offset(1) = grade And twk.Offset(2) = class Then
  65.                     For Each sec In secarea
  66.                         Set tsec = totalsecarea.Find(sec.Value)
  67.                         If tsec.Value <> "" Then course = .Cells(tsec.Row, twk.Column).Value
  68.                         teacher = teach(grade, class, course)
  69.                         If Sheets("班级课表").Cells(sec.Row, "c") = "课程" Then Sheets("班级课表").Cells(sec.Row, wk.Column) = course
  70.                         If Sheets("班级课表").Cells(sec.Row, "c") = "教师" Then Sheets("班级课表").Cells(sec.Row, wk.Column) = teacher
  71.                     Next
  72.                 End If
  73.                 Set twk = totalweekarea.FindNext(twk)
  74.             Loop Until twk.Address = firstadd
  75.             Next
  76.        End With
  77. End Sub
  78. Function teach(ByVal rng1 As Long, ByVal rng2 As Long, ByVal cse As String)
  79.     Dim gra As Range, cour As Range, firstadd As String, teacher As String
  80.     With Sheets("教学分工")
  81.     Set cour = Range(.[A3], .[A3].End(xlDown)).Find(cse)
  82.     Set gra = Range(.[A2], .[A2].End(xlToRight)).Find(rng1)
  83.     If gra Is Nothing Then Exit Function
  84.     firstadd = gra.Address
  85.     Do
  86.         If gra.Offset(1) = rng2 Then
  87.             teacher = .Cells(cour.Row, gra.Column)
  88.             teach = teacher
  89.             Exit Do
  90.         End If
  91.         Set gra = .[A2].CurrentRegion.FindNext(gra)
  92.     Loop Until gra.Address = firstadd
  93.     End With
  94. End Function

  95. '个人课表
  96. Private Sub Worksheet_Change(ByVal Target As Range)
  97.     If Intersect([B3], Target) Is Nothing Then Exit Sub
  98.     Call person
  99. End Sub
  100. Sub person()
  101.     Dim weekarea As Range, secarea As Range, nm As Range, wk As Range, sec As Range, coursearea As Range, cour As Range, teacharea As Range
  102.     Dim name As String, firstadd As String, firstcour As String, grade As String, class As String, course As String, section As String, week As String, teacher As String
  103.     With Sheets("个人课表")
  104.          .[D6:J11,D13:J16,D18:J23,D25:J32].ClearContents
  105.         name = .[B3]
  106.         Set secarea = Range(.[B6], .Range("b" & Rows.Count).End(xlUp).Offset(1))
  107.         Set weekarea = Range(.[D5], .[H5])
  108.     End With
  109.     With Sheets("总课表")
  110.          Set coursearea = .[A3].CurrentRegion
  111.     End With
  112.     With Sheets("教学分工")
  113.         Set teacharea = .[A2].CurrentRegion
  114.         For Each nm In teacharea
  115.             If nm.Value = name Then
  116.                 teacher = nm
  117.                 grade = .Cells(2, nm.Column)
  118.                 class = .Cells(3, nm.Column)
  119.                 course = .Cells(nm.Row, 1)
  120.                 Set cour = coursearea.Find(course)
  121.                 If Not cour Is Nothing Then
  122.                     firstcour = cour.Address
  123.                     Do
  124.                        If Sheets("总课表").Cells(4, cour.Column) = grade And Sheets("总课表").Cells(5, cour.Column) = class Then
  125.                            section = Sheets("总课表").Cells(cour.Row, 3).Offset(0, -1)
  126.                            If section = "" Then section = "早自习"
  127.                            week = Sheets("总课表").Cells(3, cour.Column)
  128.                            For Each wk In weekarea
  129.                                If wk.Value = week Then
  130.                                    For Each sec In secarea
  131.                                        If sec.Value = section Then
  132.                                            If Sheets("个人课表").Cells(sec.Row, "c") = "课程" Then
  133.                                                If Sheets("个人课表").Cells(sec.Row, wk.Column) <> "" Then
  134.                                                    MsgBox "周" & wk & "第" & sec & "节重啦!"
  135.                                                 End If
  136.                                                Sheets("个人课表").Cells(sec.Row, wk.Column) = course
  137.                                                Sheets("个人课表").Cells(sec.Row, wk.Column).Offset(1) = grade & "." & class
  138.                                            End If
  139.                                            Exit For
  140.                                         End If
  141.                                     Next
  142.                                End If
  143.                             Next
  144.                          End If
  145.                         Set cour = coursearea.FindNext(cour)
  146.                      Loop Until cour.Address = firstcour
  147.                 End If
  148.             End If
  149.         Next
  150.         If teacher = "" Then MsgBox "无此教师,请重新输入!"
  151.     End With
  152. End Sub


复制代码


回复 支持 反对

使用道具 举报

发表于 2017-8-18 17:43:33 | 显示全部楼层
本帖最后由 tiantian950200 于 2017-8-23 16:46 编辑
  1. Sub 作业1不良数量()
  2.     Dim 明细 As String
  3.     Dim i1 As Long, i2 As Long, sum As Long
  4.    
  5.     For i1 = 3 To Range("G2").End(xlDown).Row '循环行数
  6.     明细 = Range("G" & i1) '将文本赋值到变量
  7.         For i2 = 1 To Len(明细) '循环文本的字符数
  8.             If Mid(明细, i2, 1) Like "#" Then '如果字符是数字
  9.                 sum = sum + Mid(明细, i2, 取数位(明细, i2))
  10.                 '累计结果,调用自定义函数取数字后面有几位数字
  11.                 i2 = i2 + 取数位(明细, i2)
  12.             End If
  13.         Next
  14.     Range("F" & i1) = sum
  15.     sum = 0
  16.     Next
  17. End Sub

  18. Function 取数位(区域 As String, 起始位置 As Long)
  19.     Dim i3 As Long
  20.    
  21.     取数位 = 1 '调用该函数就说明已经有1位数字
  22.     For i3 = 1 To Len(区域) - 起始位置 '循环字符串总数-已经匹配过的字符串数量
  23.         If Mid(区域, 起始位置 + i3, 1) Like "#" Then '判断起始位置+1之后的字符是否为数字
  24.             取数位 = 取数位 + 1 '如果是,函数返回值+1
  25.         Else
  26.             Exit For '如果不是就退出循环
  27.         End If
  28.     Next
  29. End Function
复制代码
  1. Sub 作业2找舞伴() '对着视频写的,不解释了
  2.     Dim i1 As Long, i2 As Long
  3.     Dim 验证数 As Long
  4.     Dim rng1 As Range, rng2 As Range
  5.    
  6.     Set rng1 = Range("A1").CurrentRegion
  7.     验证数 = (rng1.Rows.Count - 1) / 2 + 1
  8.     i2 = 3
  9.     For i1 = 2 To rng1.Rows.Count
  10.         If Range("F1").CurrentRegion.Find(Cells(i1, "A")) Is Nothing Then
  11.             If Cells(i1, "B") = "男" Then
  12.                 Cells(i2, "F") = Cells(i1, "A")
  13.                 Cells(i2, "G") = 对象(i1, rng1, 验证数)
  14.             Else
  15.                 Cells(i2, "G") = Cells(i1, "A")
  16.                 Cells(i2, "F") = 对象(i1, rng1, 验证数)
  17.             End If
  18.             i2 = i2 + 1
  19.         End If
  20.     Next
  21. End Sub

  22. Function 对象(i1 As Long, rng1 As Range, 验证数 As Long)
  23.     Dim rng2 As Range
  24.    
  25.     Set rng2 = rng1.Find(验证数 - Cells(i1, "C"))
  26.     If rng2.Offset(, -1) = Cells(i1, "B") Then
  27.         Set rng2 = rng1.FindNext(rng2)
  28.     End If
  29.     对象 = rng2.Offset(, -2)
  30. End Function
复制代码
  1. '毕业题,模块部分,自定义函数
  2. Function Xlookup1(星期 As String, 年级 As Long, 班级 As Long, 课次)
  3.     Dim i As Long, col As Long, row As Long
  4.     Sheets("总课表").Activate
  5.     For i = 1 To Sheets("总课表").Range("A1").CurrentRegion.Columns.Count
  6.         If Cells(3, i) = 星期 And Cells(4, i) = 年级 And Cells(5, i) = 班级 Then col = i
  7.         '如果单元格上面表头的星期 , 年级和班级与传进参数一致, 赋值变量
  8.     Next
  9.     For i = 1 To Sheets("总课表").Range("A1").CurrentRegion.Rows.Count
  10.         If Cells(i, 2) = 课次 Or Cells(i, 2).Offset(0, -1) = 课次 Then row = i
  11.         '如果单元格左边的课次一致,赋值变量
  12.     Next
  13.     If col = 0 Or row = 0 Then '如果2个变量有一个没有值
  14.         Xlookup1 = "" '自定义函数值为空
  15.     Else
  16.         Xlookup1 = Cells(row, col).Value '否则将行和列的值赋值给自定义函数
  17.     End If
  18. End Function

  19. Function Xlookup2(年级 As Long, 班级 As Long, 科目 As String)
  20.     Dim i As Long, col As Long, row As Long
  21.     Sheets("教学分工").Activate
  22.     For i = 1 To Sheets("教学分工").Range("A1").CurrentRegion.Columns.Count
  23.         If Cells(2, i) = 年级 And Cells(3, i) = 班级 Then col = i
  24.         ''如果单元格上面表头的年级和班级与传进参数一致, 赋值变量
  25.     Next
  26.     For i = 1 To Sheets("总课表").Range("A1").CurrentRegion.Rows.Count
  27.         If Cells(i, 1) = 科目 Then row = i
  28.         '如果单元格左边的科目一致,赋值变量
  29.     Next
  30.     If col = 0 Or row = 0 Then '如果2个变量有一个没有值
  31.         Xlookup2 = "" '自定义函数值为空
  32.     Else
  33.         Xlookup2 = Cells(row, col).Value '否则将行和列的值赋值给自定义函数
  34.     End If
  35. End Function

  36. '毕业题,班级课表事件部分
  37. Private Sub Worksheet_Change(ByVal Target As Range)
  38.    Dim 星期 As String, 年级 As Long, 班级 As Long, 课次
  39.    Dim rng As Range
  40.    
  41.     If Target.Address = Range("B3").Address Or Target.Address = Range("C3").Address Then
  42.     '如果这2个单元格有输入内容
  43.         Application.ScreenUpdating = False '关闭更新
  44.         年级 = Sheets("班级课表").Range("B3")
  45.         班级 = Sheets("班级课表").Range("C3")
  46.         For Each rng In Sheets("班级课表").Range("D6", "J32") '在班级课表内循环
  47.             Sheets("班级课表").Activate
  48.             If rng.Offset(0, 3 - rng.Column) = "课程" Then '如果单元格前面是课程字符串
  49.                 星期 = Cells(5, rng.Column) '赋值星期
  50.                 课次 = Cells(rng.row, "B") '赋值课次
  51.                 rng.Value = Xlookup1(星期, 年级, 班级, 课次) '自定义查找并填写单元格
  52.                 rng.Offset(1, 0).Value = Xlookup2(年级, 班级, rng.Value) '填写下方的单元格
  53.             End If
  54.         Next
  55.         Application.ScreenUpdating = True
  56.     End If
  57. End Sub


  58. '毕业题,个人课表事件部分
  59. Private Sub Worksheet_Change(ByVal Target As Range)
  60.    Dim 星期 As String, 年级 As Long, 班级 As Long, 课次, 教师 As String, 学科 As String
  61.    Dim rng1 As Range, rng2 As Range
  62.    
  63.     If Target.Address = Range("B3").Address Then '如果有输入动作
  64.         Application.ScreenUpdating = False '关闭屏幕更新
  65.         Range("D6", "J32") = "" '清除内容
  66.         教师 = Sheets("个人课表").Range("B3") '教师变量赋值
  67.         For Each rng1 In Sheets("个人课表").Range("D6", "J32") '在个人课表里循环
  68.             Sheets("个人课表").Activate '激活活动工作表
  69.             If rng1.Offset(0, 3 - rng1.Column) = "课程" Then '如果循环的单元格前面是课程字符串
  70.                 星期 = Cells(5, rng1.Column) '赋值当前单元格的星期
  71.                 课次 = Cells(rng1.row, "B") '赋值当前单元格的课次
  72.                 For Each rng2 In Sheets("教学分工").Range("A1").CurrentRegion '在教学分工表里循环
  73.                     Sheets("教学分工").Activate '激活活动单元格
  74.                     If rng2.Value = 教师 Then '如果找到老师的名字
  75.                         年级 = Sheets("教学分工").Cells(2, rng2.Column).Value '赋值当前单元格的年级
  76.                         班级 = Sheets("教学分工").Cells(3, rng2.Column).Value '赋值当前单元格的班级
  77.                         学科 = Sheets("教学分工").Cells(rng2.row, "A").Value '赋值当前单元格的学科
  78.                         If Xlookup1(星期, 年级, 班级, 课次) = 学科 Then '自定义函数查找,如果学科一致
  79.                             rng1.Value = 学科 '写入单元格
  80.                             rng1.Offset(1, 0).Value = 年级 & "级" & 班级 & "班" '写入单元格下方的年级和班级
  81.                         End If
  82.                     End If
  83.                 Next
  84.             End If
  85.         Next
  86.         Application.ScreenUpdating = True '恢复屏幕更新
  87.     End If
  88. End Sub




复制代码

回复 支持 反对

使用道具 举报

发表于 2017-8-19 13:06:56 | 显示全部楼层
作业1:从字符串提取数字并求和
  1. Option Explicit

  2. Function 返回数字(str As String)
  3.     Dim k As Long
  4.     k = 1
  5.     返回数字 = Mid(str, k, 1) * 1
  6.     Do Until Not (Mid(str, k + 1, 1) Like "[0-9]")
  7.         k = k + 1
  8.         返回数字 = 返回数字 * 10 + Mid(str, k, 1)
  9.     Loop
  10. End Function

  11. Sub 从字符串提取数字并求和()
  12.     Dim s As String, i As Long, j As Long, sum As Long
  13.     For i = 3 To 5
  14.         sum = 0
  15.         s = Range("g" & i)
  16.         For j = 1 To Len(s)
  17.             If Mid(s, j, 1) Like "[0-9]" Then
  18.                 If j = 1 Or (Not Mid(s, j - 1, 1) Like "[0-9]") Then
  19.                     sum = sum + 返回数字(Mid(s, j, Len(s) - j + 1))
  20.                 End If
  21.             End If
  22.            
  23.         Next
  24.         Range("f" & i) = sum
  25.     Next
  26. End Sub
复制代码



作业2:武林大会之交换舞伴
  1. Option Explicit

  2. Sub 寻找舞伴()
  3.    Dim 舞伴对数 As Long, i As Long, j As Long, m As Long, w As Long, k As Long
  4.     舞伴对数 = (Range("a1").CurrentRegion.Rows.count - 1) / 2
  5.     i = 2
  6.     m = 3
  7.     w = 3
  8.     For i = 2 To Range("a1").CurrentRegion.Rows.count
  9.         If Range("f2").CurrentRegion.Find(Range("a" & i).Value) Is Nothing Then
  10.             If Range("b" & i) = Range("f2") Then
  11.                Range("f" & m) = Range("a" & i)
  12.                m = m + 1
  13.                For j = 2 To Range("a1").CurrentRegion.Rows.count
  14.                    If Range("b" & j) = Range("g2") And Range("c" & j) = 舞伴对数 + 1 - Range("c" & i) Then
  15.                            Range("g" & w) = Range("a" & j)
  16.                            w = w + 1
  17.                            Exit For
  18.                     End If
  19.                Next
  20.              Else
  21.                 Range("g" & w) = Range("a" & i)
  22.                 w = w + 1
  23.                 For j = 2 To Range("a1").CurrentRegion.Rows.count
  24.                    If Range("b" & j) = Range("f2") And Range("c" & j) = 舞伴对数 + 1 - Range("c" & i) Then
  25.                            Range("f" & m) = Range("a" & j)
  26.                            m = m + 1
  27.                            Exit For
  28.                     End If
  29.                 Next
  30.             End If
  31.         End If
  32.     Next
  33. End Sub
复制代码




毕业设计课程表

  1. Option Explicit

  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3.     '匹配班级课表
  4.     Application.ScreenUpdating = False
  5.     Application.EnableEvents = False
  6.     Dim i As Long, j As Long, l As Long, n As Long
  7.     For i = 6 To 3
  8.         For j = 4 To 8
  9.             If Cells(i, 3) = "课程" Or Cells(i, 3) = "教师" Then
  10.                 Cells(i, j) = ""
  11.             End If
  12.         Next
  13.     Next
  14.     i = 0
  15.     j = 0

  16.      For n = 4 To 8
  17.         For l = 6 To 32
  18.            If Worksheets("班级课表").Cells(l, 3) = "课程" Then
  19.                 For i = 3 To 77
  20.                     For j = 6 To 19
  21.                         If Worksheets("总课表").Cells(3, i) = Worksheets("班级课表").Cells(5, n) Then
  22.                             If Worksheets("总课表").Cells(4, i) = Worksheets("班级课表").Cells(3, 2) Then
  23.                                 If Worksheets("总课表").Cells(5, i) = Worksheets("班级课表").Cells(3, 3) Then
  24.                                     If (Worksheets("总课表").Cells(j, 2) = Worksheets("班级课表").Cells(l, 2) Or Worksheets("总课表").Cells(j, 1) = Worksheets("班级课表").Cells(l, 2)) Then
  25.                                          Worksheets("班级课表").Cells(l, n) = Worksheets("总课表").Cells(j, i)
  26.                                         Exit For
  27.                                     End If
  28.                                 Else
  29.                                     Exit For
  30.                                 End If
  31.                             Else
  32.                                 Exit For
  33.                             End If

  34.                         Else
  35.                             Exit For
  36.                         End If
  37.                     Next
  38.                 Next
  39.             End If
  40.         Next
  41.     Next
  42.     n = 0
  43.     l = 0
  44.     i = 0
  45.     j = 0
  46.     For n = 4 To 8
  47.         For l = 7 To 32
  48.             If Worksheets("班级课表").Cells(l, 3) = "教师" Then
  49.                 For i = 2 To 16
  50.                     For j = 4 To 20
  51.                         If Worksheets("教学分工").Cells(2, i) = Worksheets("班级课表").Cells(3, 2) Then
  52.                             If Worksheets("教学分工").Cells(3, i) = Worksheets("班级课表").Cells(3, 3) Then
  53.                                 If Worksheets("教学分工").Cells(j, 1) = Worksheets("班级课表").Cells(l - 1, n) Then
  54.                                     Worksheets("班级课表").Cells(l, n) = Worksheets("教学分工").Cells(j, i)
  55.                                     Exit For
  56.                                 End If
  57.                             Else
  58.                                 Exit For
  59.                             End If
  60.                         Else
  61.                             Exit For
  62.                         End If
  63.                     Next
  64.                 Next
  65.             End If

  66.          Next
  67.     Next
  68.     Application.EnableEvents = True
  69.     Application.ScreenUpdating = True
  70. End Sub
复制代码



  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     '匹配个人课表
  3.     Dim n As Long, l As Long, i As Long, j As Long, a As Long, b As Long, rng As Range
  4.     Set rng = Worksheets("教学分工").Range("b4").Resize(14, 15).Find(Worksheets("个人课表").Cells(3, 2).Value)
  5.     If rng Is Nothing Then
  6.         MsgBox "输入错误。请输入教学分工表里的一位教师的姓名。"
  7.         Exit Sub
  8.     End If
  9.     Application.ScreenUpdating = False
  10.     Application.EnableEvents = False
  11.     For i = 6 To 32
  12.         For j = 4 To 8
  13.             If Worksheets("个人课表").Cells(i, 3) = "课程" Or Worksheets("个人课表").Cells(i, 3) = "班级" Then
  14.                 Worksheets("个人课表").Cells(i, j) = ""
  15.             End If
  16.         Next
  17.     Next
  18.     i = 0
  19.     j = 0
  20.      For n = 6 To 32
  21.         For l = 4 To 8
  22.             If Worksheets("个人课表").Cells(n, 3) = "课程" Then
  23.                 For i = 4 To 20
  24.                     For j = 2 To 16
  25.                         If Worksheets("教学分工").Cells(i, j) = Worksheets("个人课表").Cells(3, 2) Then
  26.                             For a = 6 To 19
  27.                                 For b = 3 To 77
  28.                                     If Worksheets("总课表").Cells(3, b) = Worksheets("个人课表").Cells(5, l) Then
  29.                                         If Worksheets("总课表").Cells(4, b) = Worksheets("教学分工").Cells(2, j) Then
  30.                                             If Worksheets("总课表").Cells(5, b) = Worksheets("教学分工").Cells(3, j) Then
  31.                                                 If Worksheets("总课表").Cells(a, b) = Worksheets("教学分工").Cells(i, 1) Then
  32.                                                   If Worksheets("总课表").Cells(a, 2) = Worksheets("个人课表").Cells(n, 2) Then
  33.                                                        Worksheets("个人课表").Cells(n, l) = Worksheets("总课表").Cells(a, b)
  34.                                                         Worksheets("个人课表").Cells(n + 1, l) = Worksheets("总课表").Cells(4, b) & "年" & Worksheets("总课表").Cells(5, b) & "班"
  35.                                                     End If
  36.                                                 Else
  37.                                                     Exit For
  38.                                                 End If
  39.                                             End If
  40.                                         End If
  41.                                     End If
  42.                                 Next
  43.                             Next

  44.                         End If
  45.                     Next
  46.                 Next
  47.             End If
  48.         Next
  49.     Next
  50.     Application.EnableEvents = True
  51.     Application.ScreenUpdating = True
  52. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2017-8-20 23:45:32 | 显示全部楼层
  1. Function statistics(ByVal rng As String)
  2.     Application.Volatile True
  3.     Dim i As Long, str As String, sum As Long
  4.     For i = 1 To Len(rng)
  5.         str = ""
  6.         Do Until Mid(rng, i, 1) Like "[!0-9]"
  7.             str = str & Mid(rng, i, 1)
  8.             i = i + 1
  9.         Loop
  10.             sum = sum + Val(str)
  11.     Next
  12.     statistics = sum
  13. End Function

  14. '作业2
  15. Sub match()
  16.     Dim i As Long, num As Long, firstadd As String, rng As Range
  17.     [F1].CurrentRegion.Offset(2).ClearContents
  18.     For i = 2 To Range("a1").CurrentRegion.Rows.Count - 1
  19.         num = 9 - Cells(i, 1).Offset(0, 2).Value
  20.         Set rng = Range("a1").CurrentRegion.Find(num)
  21.         If Not rng Is Nothing Then
  22.             firstadd = rng.Address
  23.             Do
  24.                 If rng.Offset(0, -1) <> Cells(i, 1).Offset(0, 1) Then
  25.                     If Range("f1").CurrentRegion.Find(Cells(i, 1)) Is Nothing Then
  26.                         [F1].End(xlDown).Offset(1) = IIf(Cells(i, 1).Offset(0, 1) = "男", Cells(i, 1), rng.Offset(, -2))
  27.                         [F1].End(xlDown).Offset(, 1) = IIf(Cells(i, 1).Offset(0, 1) = "女", Cells(i, 1), rng.Offset(, -2))
  28.                     End If
  29.                     Exit Do
  30.                 End If
  31.                 Set rng = Range("a1").CurrentRegion.FindNext(rng)
  32.             Loop Until rng.Address = firstadd
  33.         End If
  34.     Next
  35. End Sub


  36. '毕业设计
  37. '班级课表
  38. Private Sub Worksheet_Change(ByVal Target As Range)
  39.     If Intersect([B3:C3], Target) Is Nothing Then Exit Sub
  40.     Call grade
  41. End Sub
  42. Sub grade()
  43.         Dim grade As Long, class As Long
  44.         Dim totalsecarea As Range, tsec As Range, secarea As Range, sec As Range, totalweekarea As Range, twk As Range, weekarea As Range, wk As Range
  45.         Dim teacher As String, firstadd As String, course As String
  46.         On Error Resume Next
  47.       
  48.         With Sheets("班级课表")
  49.             .[D6:J11,D13:J16,D18:J23,D25:J32].ClearContents
  50.             grade = .[B3]
  51.             class = .[C3]
  52.             Set secarea = Range(.[B6], .Range("b" & Rows.Count).End(xlUp).Offset(1))
  53.             Set weekarea = Range(.[D5], .[H5])
  54.         End With
  55.         With Sheets("总课表")
  56.             Set totalsecarea = Range(.[A6], .[B19])
  57.             Set totalweekarea = Range(.[C3].Offset(0, -1), .[C3].End(xlToRight))
  58.             For Each wk In weekarea
  59.                 Set twk = totalweekarea.Find(wk.Value)
  60.                 If Not twk Is Nothing Then firstadd = twk.Address
  61.                 Do
  62.                 If twk.Offset(1) = grade And twk.Offset(2) = class Then
  63.                     For Each sec In secarea
  64.                         Set tsec = totalsecarea.Find(sec.Value)
  65.                         If tsec.Value <> "" Then course = .Cells(tsec.Row, twk.Column).Value
  66.                         teacher = teach(grade, class, course)
  67.                         If Sheets("班级课表").Cells(sec.Row, "c") = "课程" Then Sheets("班级课表").Cells(sec.Row, wk.Column) = course
  68.                         If Sheets("班级课表").Cells(sec.Row, "c") = "教师" Then Sheets("班级课表").Cells(sec.Row, wk.Column) = teacher
  69.                     Next
  70.                 End If
  71.                 Set twk = totalweekarea.FindNext(twk)
  72.             Loop Until twk.Address = firstadd
  73.             Next
  74.        End With
  75. End Sub
  76. Function teach(ByVal rng1 As Long, ByVal rng2 As Long, ByVal cse As String)
  77.     Dim gra As Range, cour As Range, firstadd As String, teacher As String
  78.     With Sheets("教学分工")
  79.     Set cour = Range(.[A3], .[A3].End(xlDown)).Find(cse)
  80.     Set gra = Range(.[A2], .[A2].End(xlToRight)).Find(rng1)
  81.     If gra Is Nothing Then Exit Function
  82.     firstadd = gra.Address
  83.     Do
  84.         If gra.Offset(1) = rng2 Then
  85.             teacher = .Cells(cour.Row, gra.Column)
  86.             teach = teacher
  87.             Exit Do
  88.         End If
  89.         Set gra = .[A2].CurrentRegion.FindNext(gra)
  90.     Loop Until gra.Address = firstadd
  91.     End With
  92. End Function

  93. '个人课表
  94. Private Sub Worksheet_Change(ByVal Target As Range)
  95.     If Intersect([B3], Target) Is Nothing Then Exit Sub
  96.     Call person
  97. End Sub
  98. Sub person()
  99.     Dim weekarea As Range, secarea As Range, nm As Range, wk As Range, sec As Range, coursearea As Range, cour As Range, teacharea As Range
  100.     Dim name As String, firstadd As String, firstcour As String, grade As String, class As String, course As String, section As String, week As String, teacher As String
  101.     With Sheets("个人课表")
  102.          .[D6:J11,D13:J16,D18:J23,D25:J32].ClearContents
  103.         name = .[B3]
  104.         Set secarea = Range(.[B6], .Range("b" & Rows.Count).End(xlUp).Offset(1))
  105.         Set weekarea = Range(.[D5], .[H5])
  106.     End With
  107.     With Sheets("总课表")
  108.          Set coursearea = .[A3].CurrentRegion
  109.     End With
  110.     With Sheets("教学分工")
  111.         Set teacharea = .[A2].CurrentRegion
  112.         For Each nm In teacharea
  113.             If nm.Value = name Then
  114.                 teacher = nm
  115.                 grade = .Cells(2, nm.Column)
  116.                 class = .Cells(3, nm.Column)
  117.                 course = .Cells(nm.Row, 1)
  118.                 Set cour = coursearea.Find(course)
  119.                 If Not cour Is Nothing Then
  120.                     firstcour = cour.Address
  121.                     Do
  122.                        If Sheets("总课表").Cells(4, cour.Column) = grade And Sheets("总课表").Cells(5, cour.Column) = class Then
  123.                            section = Sheets("总课表").Cells(cour.Row, 3).Offset(0, -1)
  124.                            If section = "" Then section = "早自习"
  125.                            week = Sheets("总课表").Cells(3, cour.Column)
  126.                            For Each wk In weekarea
  127.                                If wk.Value = week Then
  128.                                    For Each sec In secarea
  129.                                        If sec.Value = section Then
  130.                                            If Sheets("个人课表").Cells(sec.Row, "c") = "课程" Then
  131.                                                If Sheets("个人课表").Cells(sec.Row, wk.Column) <> "" Then
  132.                                                    MsgBox "周" & wk & "第" & sec & "节重啦!"
  133.                                                 End If
  134.                                                Sheets("个人课表").Cells(sec.Row, wk.Column) = course
  135.                                                Sheets("个人课表").Cells(sec.Row, wk.Column).Offset(1) = grade & "." & class
  136.                                            End If
  137.                                            Exit For
  138.                                         End If
  139.                                     Next
  140.                                End If
  141.                             Next
  142.                          End If
  143.                         Set cour = coursearea.FindNext(cour)
  144.                      Loop Until cour.Address = firstcour
  145.                 End If
  146.             End If
  147.         Next
  148.         If teacher = "" Then MsgBox "无此教师,请重新输入!"
  149.     End With
  150. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2017-8-22 08:09:18 | 显示全部楼层
  1. <div>作业1:从字符串中自动提取数字求和</div><div>Function 作业(i As Range)
  2.     Dim j As Long, e As String, w As Long, 辅助 As Long
  3.     Dim sumw As Long, 结果 As Long, sum As Long
  4.     Application.Volatile '设置为易失性函数
  5.    
  6.     For j = 1 To Len(i) '将字符串分开,长度为1
  7.         
  8.         sum = j + sumw 'sumv代表已经提取出来的数字的长度,防止重复提取
  9.         
  10.         e = Mid(i, sum, 1) '提取单个字符,并赋值给e
  11.         
  12.         If e Like "[0-9]" Then '如果e是数字
  13.             
  14.             w = 0 'w是do循环中的变量,用于计算提取的字符长度。每次计算都将清零重算。

  15.             Do While IsNumeric(e) '如果是数字,则进入循环
  16.                   
  17.                 w = w + 1 '提取长度增加1
  18.                
  19.                 e = Mid(i, sum, w) '如果为数字,则从该数字后面提取,直到不再为数字时,退出循环
  20.             
  21.             Loop
  22.             
  23.             结果 = 结果 + Left(e, Len(e) - 1) 'e最终退出循环时,多一个文本值
  24.             
  25.             w = w - 1 '多计算1

  26.             sumw = sumw + w '将w每次累加。
  27.    
  28.         End If
  29.         
  30.     Next
  31.    
  32.     作业 = 结果 '输出结果。

  33. End Function
  34. </div>
复制代码
  1. Sub 作业2()
  2.     Dim i As Long, 行 As Long, 辅助 As Long
  3.     Dim 查找范围 As Range, 答案 As Range, sum As Range
  4.    
  5.     i = (Worksheets(1).Range("A1").End(xlDown).Row - 1) / 2 'i 为变动的舞伴对数
  6.     Set 查找范围 = Range("C2:C" & i * 2 + 1) 'c列有效数据区域为查找范围
  7.   
  8.     辅助 = 3 '答题区为第三行开始
  9.     For 行 = 2 To i * 2 + 1 '数据区域的行
  10.         
  11.         Set 答案 = Worksheets(1).Range("F2").CurrentRegion '每查找完一对,重新定义答案区域
  12.         
  13.         If 答案.Find(Range("A" & 行)) Is Nothing Then '如果这次需要处理的姓名没有在答案区域出现 ,则处理
  14.             
  15.             
  16.             If Range("B" & 行) = "男" Then '如果性别为男,则在男那一列写入答案
  17.                
  18.                 Range("F" & 辅助) = Range("A" & 行)
  19.             
  20.             Else
  21.                
  22.                 Range("G" & 辅助) = Range("A" & 行) '否则在女那一列写入答案
  23.   
  24.             End If
  25.     '上面是按顺序写入人员。后面是按写入的人员,找对应的舞伴
  26.             For Each sum In 查找范围
  27.                
  28.                 If (sum + Range("C" & 行) = i + 1) _
  29.                  And Range("B" & sum.Row) <> Range("B" & 行) Then
  30.                     
  31.                     If Range("b" & 行) = "男" Then
  32.                         Range("G" & 辅助) = Range("A" & sum.Row)
  33.                        Exit For
  34.                     Else
  35.                         Range("F" & 辅助) = Range("A" & sum.Row)
  36.                         Exit For
  37.                     End If
  38.                 End If

  39.             Next
  40.             辅助 = 辅助 + 1
  41.         End If
  42.     Next



  43. End Sub
复制代码



回复 支持 反对

使用道具 举报

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

本版积分规则

关闭

站长推荐上一条 /2 下一条

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