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

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

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

交作业的要求:

1、不需要附件,只需贴代码,说明你做的是哪道题
2、贴上的代码都需要缩进,并且关键语句要有注释
3、请在添加代码文字,那里添加代码,这样代码在楼层中显得赏心悦目。不知道怎样操作的小伙伴,可以参照看动画
221248tee8m9ceat8zo9mw.gif
回复

使用道具 举报

发表于 2017-8-10 13:52:29 | 显示全部楼层
本帖最后由 cynthiashi 于 2017-8-14 14:12 编辑

Function OEstr(rng As Range) As String '8月9号作业1自定义函数练习之奇偶数

    Dim i&, j&, num&, nOdd&, nEven&
    Dim resultO As String, resultE As String
    For i = 0 To rng.Count - 1
        If Cells(rng.Row, rng.Column + i).Value Mod 2 <> 0 Then
            nOdd = nOdd + 1
            resultO = resultO & ";" & Cells(rng.Row, rng.Column + i)
        Else
            nEven = nEven + 1
            resultE = resultE & ";" & Cells(rng.Row, rng.Column + i)
        End If
    Next
    If nEven > nOdd Then
         OEstr = resultE
    Else
         OEstr = resultO
    End If
    If InStr(OEstr, ";") = 1 Then OEstr = Mid(OEstr, 2, Len(OEstr) - 1)
End Function



Private Sub Worksheet_Change(ByVal target As Range) '8月9号工作表事件响应作业之星座
   
    Dim rng As Range
    If target.Address = [b1].Address Then
        Range("b3").Offset(0, -1).CurrentRegion.ClearContents
        With Sheets("Sheet1")
            Set rng = .[a2].Resize(.[a1].CurrentRegion.Rows.Count - 1, .[a1].CurrentRegion.Columns.Count)
            rng.AutoFilter Field:=4, Criteria1:=[b1].Value
            rng.SpecialCells(xlCellTypeVisible).Copy [b3].Offset(0, -1)
            rng.AutoFilter
        End With
    Else
        Exit Sub
    End If
   
End Sub




Private Sub Worksheet_SelectionChange(ByVal Target As Range) '8月9号工作表事件响应作业之聚光灯
    Cells.Interior.Color = xlNone
    If Target.Row > [a1].CurrentRegion.Rows.Count Or Target.Column > [a1].CurrentRegion.Columns.Count Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    Range(Target.End(xlUp), Cells([a1].CurrentRegion.Rows.Count, Target.Column)).Interior.Color = vbGreen
    Range(Target.End(xlToLeft), Cells(Target.Row, [a1].CurrentRegion.Columns.Count)).Interior.Color = vbYellow

End Sub



回复 支持 反对

使用道具 举报

发表于 2017-8-11 16:26:50 | 显示全部楼层
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     'CNN第十四课时作业题0小型聚光灯
  3.     Dim rng As Range        '定义目标选定区域
  4.     Dim area As Range       '定义数据区域
  5.     Dim sht As Worksheet    '定义数据工作表
  6.     Dim 偏移的列数 As Long  '定义目标选定区域至数据区最左侧偏移的列数
  7.     Dim 偏移的行数 As Long  '定义目标选定区域至数据区最上侧偏移的行数
  8.     Dim 竖灯 As Range       '定义目标选定区域所在竖列
  9.     Dim 横灯 As Range       '定义目标选定区域所在横列
  10.     Set sht = Worksheets("SHEET2")    '设置数据工作表
  11.     Set area = sht.Range("A1").CurrentRegion  '设置数据区域
  12.     Set rng = Target                          '设置目标选定区域
  13.     If rng.Offset(1, 1).CurrentRegion.Count = 1 Then   '如果目标选定区域所在的当前区域所有元素个数为1,即如果目标选定区域在数据区外,则恢复原状,退出
  14.         Cells.Interior.Color = xlNone
  15.         Exit Sub
  16.     ElseIf rng.Count > 1 Then        '如果目标选定区域元素个数大于1,即如果目标选定区域为多行多列,则恢复原状,退出
  17.         Cells.Interior.Color = xlNone
  18.         Exit Sub
  19.     Else
  20.         Cells.Interior.Color = xlNone        '如果目标选定区域在数据区域内,且为单个单元格,执行操作。
  21.         偏移的列数 = 1 - rng.Column          '计算偏移的列数
  22.         偏移的行数 = 1 - rng.Row             '计算偏移的行数
  23.         Set 横灯 = rng.Offset(0, 偏移的列数).Resize(1, area.Columns.Count) '设置目标选定区域所在横行
  24.         Set 竖灯 = rng.Offset(偏移的行数, 0).Resize(area.Rows.Count, 1)  '设置目标选定区域所在竖列
  25.         横灯.Interior.Color = vbGreen      '目标选定区域所在横行底色设为绿色
  26.         竖灯.Interior.Color = vbRed        '目标选定区域所在竖列底色设为绿色
  27.     End If
  28. End Sub
复制代码
  1. Function modstr(tarray As Range)
  2.     'CNN第十四课时作业题1自定义函数
  3.     Dim rng As Range           '定义遍历区域元素
  4.     Dim arng As Range          '定义遍历区域
  5.     Dim jcount As Long         '定义奇数个数
  6.     Dim ocount As Long         '定义偶数个数
  7.     Dim jnum As String         '定义奇数值
  8.     Dim onum As String         '定义偶数值
  9.     Set arng = tarray          '设置遍历区域为传值区域
  10.     If arng.Rows.Count > 1 Then  '如果选择的区域多余一行,则提示错误
  11.         modstr = "区域选择错误,请选择数据区内A列至C列的任意一行!"
  12.     Else
  13.         For Each rng In arng             '在区域中遍历判断
  14.             If rng Mod 2 = 0 Then        '如果数字为偶数则数字+分隔符累加,同时偶数计数加1
  15.                 onum = onum & ";" & rng
  16.                 ocount = ocount + 1
  17.             Else
  18.                 jnum = jnum & ";" & rng   '如果数字为奇数则数字+分隔符累加,同时奇数计数加1
  19.                 jcount = jcount + 1
  20.             End If
  21.         Next
  22.         If ocount >= 2 Then               '如果偶数大于两个,则用right和len函数去掉结果中多余的开头分号,返回值。也可以在分支中排除,不过分支看起来更复杂。
  23.             modstr = Right(onum, Len(onum) - 1)
  24.         Else
  25.             If jcount >= 2 Then
  26.                 modstr = Right(jnum, Len(jnum) - 1)
  27.             End If
  28.         End If
  29.     End If
  30. End Function
复制代码
  1. Private Sub Worksheet_Change(ByVal target As Range)
  2.     'CNN第十四课时作业题2星座
  3.     Dim rng As Range          '定义遍历区域元素
  4.     Dim arng As Range         '定义遍历区域
  5.     Dim sht As Worksheet       '定义源工作表
  6.     Dim area As Range          '定义源数据区域
  7.     Dim i As Long              '定义符合条件的元素个数
  8.     Set sht = Worksheets("sheet1")            '设置源工作表
  9.     Set area = sht.Range("a1").CurrentRegion  '设置源数据区域
  10.     Set arng = area.Offset(1, area.Columns.Count - 1).Resize(area.Rows.Count - 1, 1) '设置遍历数据区域
  11.     Application.EnableEvents = False           '关闭事件响应
  12.     Range("a4:d13").ClearContents              '清空结果数据区数据
  13.     For Each rng In arng                       '遍历开始
  14.         If target.Value = rng.Value Then       '如果遍历区域元素与变动值相等,执行操作
  15.             Range("A" & i + 4) = rng.Offset(0, -3)  '将姓名写入目标数据区
  16.             Range("B" & i + 4) = rng.Offset(0, -2)  '将性别写入目标数据区
  17.             Range("C" & i + 4) = rng.Offset(0, -1)  '将生日写入目标数据区
  18.             Range("D" & i + 4) = rng.Offset(0, 0)   '将星座写入目标数据区
  19.             i = i + 1                               '计数加1,进行下一轮
  20.         End If
  21.     Next
  22.     Application.EnableEvents = True                 '事件响应恢复
  23. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2017-8-12 21:35:08 | 显示全部楼层
  1. Option Explicit

  2. '事件作业1:如果你选择的单元格不在[a1].currentregion 之内,则不响应事件。
  3. 'exit sub
  4. '如果你选择的单元格超过1 个,也不响应
  5. '聚光灯的颜色不限,行和列可以不同色。但是行和列不可以超越到没有数据的区域。

  6. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  7.     Cells.Interior.Color = xlNone
  8. '    MsgBox Target.Address
  9. '    If Target.Row <= [a1].CurrentRegion.Rows.Count And _
  10. '       Target.Column <= [a1].CurrentRegion.Columns.Count And _
  11. '       Target.Rows.Count = 1 And Target.Columns.Count = 1 Then
  12.     If Intersect(Target, [a1].CurrentRegion) Is Nothing Or Target.Count > 1 Then
  13.         Exit Sub   '反向分支,如果target与[a1]表格区域没有交集或者target不止一个单元格时,退出事件
  14.     Else
  15.         Target.Offset(0, 1 - Target.Column).Resize(1, Target.CurrentRegion.Columns. _
  16.         Count).Interior.Color = vbGreen '区域行填色
  17.         
  18.         Target.Offset(1 - Target.Row, 0).Resize(Target.CurrentRegion.Rows.Count, 1) _
  19.         .Interior.Color = vbGreen       '区域列填色
  20.     End If
  21.    
  22. End Sub

  23. '题目要求:
  24. '1、A2:C18是0-9的随机数;
  25. '2、以是奇数或偶数为条件;
  26. '3、去除只出现1次的奇数或偶数;
  27. '  (即:奇数多保留奇数,偶数多保留偶数)
  28. '4、结果用分号连接
  29. Function odven(rng As Range)
  30.     Dim i&, str As String, rang As Range
  31.     Application.Volatile True '将自定义函数设为易失性函数
  32.     For Each rang In rng
  33.         If rang.Value Mod 2 = 1 Then
  34.         i = i + 1
  35.         End If
  36.     Next
  37.     If i > rng.Columns.Count / 2 Then   '如果奇数时,奇数值连接
  38.         For Each rang In rng
  39.             If rang.Value Mod 2 = 1 Then
  40.                 str = str & rang & ";"
  41.             End If
  42.         Next
  43.     ElseIf i < rng.Columns.Count / 2 Then '如果偶数时,偶数连接
  44.         For Each rang In rng
  45.             If rang.Value Mod 2 = 0 Then
  46.                 str = str & rang & ";"
  47.             End If
  48.         Next
  49.     Else                            '当i=rng.columns.count/2,即分不清奇偶多少时,直接退出
  50.         Exit Function
  51.         
  52.     End If
  53.             
  54.     odven = Left(str, Len(str) - 1)         '利用公式去掉最后的“;”

  55. End Function

  56. '作业说明:当B2 的数据有效性发生改变时,要求从B3 开始的表格自动响应。
  57. '从Sheet1 把相应的星座信息复制到B4 开始的表格内,当再次发生改变时,
  58. '之前的数据要清除掉,将新的数据复制过来。

  59. Private Sub Worksheet_Change(ByVal Target As Range)
  60.     Application.EnableEvents = False
  61.     If Target.Address <> [b2].Address Then
  62.         Exit Sub
  63.     Else
  64.    
  65.         Range("a3:d10").ClearContents
  66.         With Sheets("Sheet1").Range("a2:d12")
  67.             .AutoFilter Field:=4, Criteria1:=Target '以变化后的内容在sheet1里进行筛选
  68.         
  69.             .SpecialCells(xlCellTypeVisible).Copy       '复制可见单元格
  70.         
  71.             Sheets("事件响应作业").[A4].PasteSpecial Paste:=xlPasteValues   '选择性粘贴
  72.         
  73.             .AutoFilter         '恢复筛选前的表格状态
  74.         
  75.         End With
  76.      End If
  77.      Application.EnableEvents = True
  78. End Sub

复制代码


回复 支持 反对

使用道具 举报

发表于 2017-8-15 15:22:36 | 显示全部楼层
  1. 作业1

  2. Function modstr(area As Range)
  3.     Dim i As Long, 奇数 As Long, 偶数 As Long, rng As Range
  4.     For Each rng In area
  5.         If rng = 0 Or rng Mod 2 = 0 Then
  6.             偶数 = 偶数 + 1
  7.         Else
  8.             奇数 = 奇数 + 1
  9.         End If
  10.     Next
  11.     For i = 0 To area.Count - 1
  12.          Set rng = area.Resize(1, 1).Offset(, i)

  13.         If 偶数 > 奇数 Then
  14.             If rng = 0 Or rng Mod 2 = 0 Then modstr = modstr & ";" & rng
  15.         Else
  16.             If rng <> 0 And rng Mod 2 <> 0 Then modstr = modstr & ";" & rng
  17.         End If

  18.     Next
  19.     modstr = Right(modstr, Len(modstr) - 1)
  20.    
  21. End Function

复制代码


  1. Private Sub Worksheet_Change(ByVal Target As Range)

  2.     If Target.Address <> Worksheets("事件响应作业").[b1].Address Then
  3.         Exit Sub
  4.     Else
  5.         Dim rng As Range, i As Long
  6.         With Worksheets(2)
  7.         Worksheets(2).[a3].CurrentRegion.Offset(1, 0).ClearContents
  8.         For Each rng In Sheet1.Range("d2", "d" & Sheet1.[a2].CurrentRegion.Rows.Count - 1)
  9.             If rng.Value = Worksheets(2).[b1] Then
  10.                 i = Worksheets(2).[a3].CurrentRegion.Rows.Count + 3
  11.                 rng.CurrentRegion.Rows(rng.Row).Copy Worksheets(2).Range("a" & i)   
  12.             End If
  13.         Next
  14.     End With
  15.     End If  

  16. End Sub
复制代码


回复 支持 反对

使用道具 举报

发表于 2017-8-15 15:23:09 | 显示全部楼层
  1. Option Explicit
  2. '自定义函数练习
  3. Function modstri(ByVal rng As Range)
  4.     If rng.Cells(1) Mod 2 = rng.Cells(2) Mod 2 Then
  5.         If rng.Cells(1) Mod 2 = rng.Cells(3) Mod 2 Then
  6.             modstri = rng.Cells(1) & ";" & rng.Cells(2) & ";" & rng.Cells(3)
  7.         Else
  8.             modstri = rng.Cells(1) & ";" & rng.Cells(2)
  9.         End If
  10.     Else
  11.         If rng.Cells(1) Mod 2 = rng.Cells(3) Mod 2 Then
  12.            modstri = rng.Cells(1) & ";" & rng.Cells(3)
  13.         Else
  14.            modstri = rng.Cells(2) & ";" & rng.Cells(3)
  15.         End If
  16.     End If
  17. End Function

  18. '星座题练习
  19. Private Sub Worksheet_Change(ByVal Target As Range)
  20.     If Target.Address <> "$B$1" Then Exit Sub
  21.     Target.Offset(3, -1).Resize(Range("a4").CurrentRegion.Count - 1, 4).ClearContents
  22.     Dim i As Long, rng As Range, fd As String
  23.     i = 4
  24.     Set rng = Worksheets(1).Range("a1").CurrentRegion.Find(Target.Value)
  25.     fd = rng.Address
  26.     Do
  27.         rng.Offset(0, -3).Resize(1, 4).Copy Worksheets("事件响应作业").Range("a" & i)
  28.         i = i + 1
  29.         Set rng = Worksheets(1).Range("a1").CurrentRegion.FindNext(rng)
  30.     Loop Until fd = rng.Address

  31. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2017-8-15 21:03:53 | 显示全部楼层
  1. Function 作业1(ByVal rng As Range)
  2. Application.Volatile
  3. Dim a As String, b As String, ar As Range
  4.     For Each ar In rng
  5.         If ar Mod 2 Then
  6.             a = a & ar & ";"
  7.         Else
  8.             b = b & ar & ";"
  9.         End If
  10.     Next
  11.     If Len(a) > Len(b) Then
  12.         作业1 = Left(a, Len(a) - 1)
  13.     Else
  14.         作业1 = Left(b, Len(b) - 1)
  15.     End If
  16. End Function

  17. Private Sub Worksheet_Change(ByVal Target As Range)
  18. Dim i As Long, h As Long
  19.     If Target.Address = "$B$1" Then
  20.         h = 4
  21.         Range("a4:d13").ClearContents
  22.             With Worksheets("sheet1")
  23.                 For i = 3 To .Range("a1").CurrentRegion.Rows.Count
  24.                     Select Case Target
  25.                     Case Is = .Range("d" & i)
  26.                      .Range("a" & i, "d" & i).Copy Worksheets("事件响应作业").Range("a" & h, "d" & h)
  27.                     h = h + 1
  28.                     End Select
  29.                 Next
  30.             End With
  31.     End If
  32. End Sub

  33. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  34.     Cells.Interior.Color = xlNone
  35.     If (Intersect(Target, [a1].CurrentRegion) Is Nothing) Or Target.Count > 1 Then Exit Sub
  36.     Set Target = Union(Target.EntireColumn, Target.EntireRow)
  37.     Intersect(Target, [a1].CurrentRegion).Interior.Color = vbBlue
  38. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2017-8-16 07:37:20 | 显示全部楼层
  1. 奔跑的夜

  2. '作业 聚光灯
  3. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  4.     Dim col As Long, row As Long
  5.     col = [a1].CurrentRegion.Columns.Count
  6.     row = [a1].CurrentRegion.Rows.Count
  7.     Cells.Interior.Color = xlNone
  8.     If (Intersect(Target, [a1].CurrentRegion) Is Nothing) Or Target.Count > 1 Then Exit Sub
  9.         Range(Cells(Target.row, 1), Cells((Target.row), col)).Interior.Color = vbGreen
  10.         Range(Cells(1, Target.Column), Cells(row, Target.Column)).Interior.Color = vbRed
  11.         Target.Interior.Color = vbYellow
  12. End Sub
复制代码
  1. '作业1 基偶判断
  2. Function 基偶判断连接(数据) As String
  3.     Application.Volatile
  4.     Dim rng As Range, 偶判断连接 As String, 基判断连接 As String, m As Long, n As Long
  5.     For Each rng In 数据
  6.             If rng.Value Mod 2 = 0 Then
  7.                 If 偶判断连接 = "" Then
  8.                    偶判断连接 = rng.Value
  9.                 Else
  10.                    偶判断连接 = 偶判断连接 & ";" & rng.Value
  11.                 End If
  12.                 m = m + 1
  13.             Else
  14.                 If 基判断连接 = "" Then
  15.                    基判断连接 = rng.Value
  16.                 Else
  17.                    基判断连接 = 基判断连接 & ";" & rng.Value
  18.                 End If
  19.                 n = n + 1
  20.             End If
  21.     Next
  22.     If m > n Then
  23.         基偶判断连接 = 偶判断连接
  24.     Else
  25.         基偶判断连接 = 基判断连接
  26.     End If
  27.         m = 0
  28.         偶判断连接 = ""
  29.         基判断连接 = ""
  30. End Function
复制代码
  1. '作业2 星座
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3.     Dim rng As Range, name As Range
  4.     If Target.Address <> "$B$1" Then
  5.         Exit Sub
  6.     Else
  7.         Application.EnableEvents = False
  8.         Worksheets("事件响应作业").Range("a4", "d" & Range("a3").CurrentRegion.Rows.Count + 3).ClearContents
  9.         Sheet1.Range("a1").CurrentRegion.AutoFilter Field:=4, Criteria1:=Worksheets("事件响应作业").Range("b1")
  10.         Set rng = Sheet1.Range("a1").CurrentRegion.SpecialCells(xlCellTypeVisible)
  11.         rng.Copy Worksheets("事件响应作业").Range("a4")
  12.         Rows("4:4").Delete Shift:=xlUp
  13.         Set name = Range(rng.Address).Offset(1, 0)
  14.         Application.EnableEvents = True
  15.     End If
  16. End Sub
复制代码

回复 支持 反对

使用道具 举报

发表于 2017-8-17 06:09:11 | 显示全部楼层
  1. '作业1
  2. Function oddandeven(ByVal rng As Range)
  3.     Application.Volatile True
  4.     Dim rng1 As Range, evencount As Long, oddcount As Long, evenstr As String, oddstr As String
  5.     For Each rng1 In rng
  6.         If rng1.Value Mod 2 = 0 Then
  7.             evencount = evencount + 1
  8.             evenstr = evenstr & ";" & rng1.Value
  9.         Else
  10.             oddcount = oddcount + 1
  11.             oddstr = oddstr & ";" & rng1.Value
  12.         End If
  13.     Next
  14.     If evencount > oddcount Then
  15.         oddandeven = Mid(evenstr, 2, Len(evenstr) - 1)
  16.     Else
  17.         oddandeven = Mid(oddstr, 2, Len(oddstr) - 1)
  18.     End If
  19. End Function

  20. ‘作业2
  21. Private Sub Worksheet_Change(ByVal Target As Range)
  22. Dim i As Long, rng As Range, fd As String
  23. If Target.Address <> "$B$1" Then Exit Sub

  24. Target.Offset(3, -1).Resize(Range("a4").CurrentRegion.Count - 1, 4).ClearContents
  25. i = 4
  26. Set rng = Sheet1.Range("a1").CurrentRegion.Find(Target.Value)
  27. If Not rng Is Nothing Then
  28. fd = rng.Address
  29. Do
  30.     rng.Offset(0, -3).Resize(1, 4).Copy Sheet2.Range("a" & i)
  31.     i = i + 1
  32.     Set rng = Sheet1.Range("a1").CurrentRegion.FindNext(rng)
  33. Loop Until fd = rng.Address
  34. End If
  35. End Sub

  36. ’作业3
  37. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  38. Cells.Interior.Color = xlNone
  39. If Intersect(Target, [a1].CurrentRegion) Is Nothing Or Target.Count > 1 Then Exit Sub
  40. Target.CurrentRegion.Rows(Target.Row).Interior.Color = vbGreen
  41. Target.CurrentRegion.Columns(Target.Column).Interior.Color = vbRed
  42. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2017-8-18 10:28:46 | 显示全部楼层
  1. Function fc(ByRef rng As Range)
  2.     Dim i As Long, sum1 As Long, sum2 As Long
  3.     Dim 结果1 As String, 结果2 As String
  4.    
  5.     Application.Volatile '定义为易失性函数
  6.     For i = 1 To rng.Count '循环单元格数量
  7.         If rng(i) Mod 2 = 0 Then
  8.             sum1 = sum1 + 1
  9.             结果1 = 结果1 & ";" & rng(i)
  10.         Else
  11.             sum2 = sum2 + 1
  12.             结果2 = 结果2 & ";" & rng(i)
  13.         End If
  14.     Next
  15.     If sum1 > sum2 Then
  16.         fc = Right(结果1, Len(结果1) - 1) 'Len去掉了前面一个;号
  17.     Else
  18.         fc = Right(结果2, Len(结果2) - 1)
  19.     End If
  20. End Function
复制代码
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     If Target.Address = Range("B1").Address Then
  3.     'B1的值变化激活事件,否则退出
  4.         Range("A3").CurrentRegion.ClearContents '清空数据
  5.         Sheets("14-2作业原始数据").Range("A2").AutoFilter Field:=4, Criteria1:=Target '筛选
  6.         Sheets("14-2作业原始数据").Range("A2").CurrentRegion.Copy Sheets("14-2作业输出").Range("A3") '复制
  7.         Sheets("14-2作业原始数据").Range("A2").AutoFilter '取消筛选
  8.     Else
  9.         Exit Sub
  10.     End If
  11. End Sub
复制代码
  1. Function GetStrByNum(文字, num As Long)
  2.     Dim i As Long, 结果 As String
  3.    
  4.     Application.Volatile
  5.     For i = 1 To Len(文字)
  6.         Select Case num
  7.             Case Is = 1
  8.                 If Mid(文字, i, 1) Like "#" Then GetStrByNum = GetStrByNum & Mid(文字, i, 1)
  9.             Case Is = 2
  10.                 If Mid(文字, i, 1) Like "[a-zA-Z]" Then GetStrByNum = GetStrByNum & Mid(文字, i, 1)
  11.             Case Is = 3
  12.                 If Mid(文字, i, 1) Like "[!0-9a-zA-Z]" Then GetStrByNum = GetStrByNum & Mid(文字, i, 1)
  13.             Case Else
  14.                 MsgBox "参数错误"
  15.         End Select
  16.     Next
  17.     If GetStrByNum = 0 Then GetStrByNum = ""
  18. End Function
复制代码


回复 支持 反对

使用道具 举报

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

本版积分规则

关闭

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

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