白话Excel函数公式 Office易学宝微视频教程合集(Excel+Word+PPT)
笨办法学VBA(从入门到精通) 高效办公必会的Office实战技巧
财务总监的Excel私房课 Excel数据透视表实战秘技
Excel图表神技
查看: 1635|回复: 10

零基础VBA 第十期 第十四课时作业贴

[复制链接]
发表于 2017-6-6 11:10:20 | 显示全部楼层 |阅读模式
本帖最后由 芬子 于 2017-6-17 20:30 编辑

交作业的要求:

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

使用道具 举报

发表于 2017-6-6 11:15:10 | 显示全部楼层
本帖最后由 抬头苦干 于 2017-6-6 23:35 编辑

作业14:(2017-06-05 安冬-UID:1700565)
  1. Option Explicit

  2. '1.自定义函数ShowTheMore
  3. Function ShowTheMore(ByVal area As Range)
  4.     Application.Volatile True
  5.     Dim odds$, evens$, rng As Range
  6.     For Each rng In area
  7.         If rng Mod 2 Then
  8.             odds = odds & rng & ";"
  9.         Else
  10.             evens = evens & rng & ";"
  11.         End If
  12.     Next
  13.     If Len(odds) > Len(evens) Then
  14.         ShowTheMore = Left(odds, Len(odds) - 1)
  15.     Else
  16.         ShowTheMore = Left(evens, Len(evens) - 1)
  17.     End If
  18. End Function
复制代码
  1. '2.模拟数据透视表按内容筛选
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3.     If Target.Address <> "$B$1" Then Exit Sub
  4.     Dim firstAddr$
  5.     [A3].CurrentRegion.Offset(1, 0).ClearContents
  6.     With [Sheet1!A1].CurrentRegion
  7.         If .Find(Target) Is Nothing Then Exit Sub
  8.         Set Target = .Find(Target)          'Target 为传值调用,可用于保存查询结果
  9.         firstAddr = Target.Address
  10.         Do                                  '复制对应行,并循环查找至最后一个
  11.             .Rows(Target.Row).Copy Range("A" & Rows.Count).End(xlUp).Offset(1)
  12.             Set Target = .FindNext(Target)
  13.         Loop Until Target.Address = firstAddr
  14.     End With
  15. End Sub
复制代码
  1. '3.聚光灯效果
  2. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  3.     ActiveSheet.UsedRange.Cells.Interior.Color = xlNone
  4.     If Target.Count > 1 Or Intersect(Target, [a1].CurrentRegion) Is Nothing Then Exit Sub
  5.     Set Target = Union(Target.EntireColumn, Target.EntireRow)
  6.     Intersect(Target, [a1].CurrentRegion).Interior.Color = vbYellow
  7. End Sub
复制代码


回复 支持 反对

使用道具 举报

发表于 2017-6-6 13:46:33 | 显示全部楼层
本帖最后由 lcqxq 于 2017-6-6 22:18 编辑

作业2:查找星座
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     If Target.Address = "$B$1" Then
  3.         Dim rng, area As Range
  4.         Dim fAddress As String
  5.         Dim i As Long
  6.         Range("A4:D13").ClearContents
  7.         Set area = Worksheets("Sheet1").Range("A1").CurrentRegion  '设置目标区域
  8.         i = 4
  9.         Set rng = area.Find(Target.Value)
  10.         If Not rng Is Nothing Then
  11.             fAddress = rng.Address
  12.             Do
  13.                 Worksheets("Sheet1").Range("A" & rng.Row).Resize(1, 4).Copy Cells(i, 1)
  14.                 i = i + 1
  15.                 Set rng = area.FindNext(rng)
  16.             Loop Until rng.Address = fAddress
  17.         End If
  18.     End If
  19. End Sub
复制代码


学生:覃晓晴









回复 支持 反对

使用道具 举报

发表于 2017-6-6 18:01:44 | 显示全部楼层
  1. Function 作业1(ByVal area As Range) As String
  2.     Dim str As String, i As Long, k As Long, rng As Range
  3.     For Each rng In area
  4.         If rng Mod 2 = 0 Then
  5.             k = k + 1
  6.         End If
  7.     Next
  8.     For Each rng In area
  9.         If k > 1 Then
  10.             If rng Mod 2 = 0 Then
  11.                 str = str & rng & ";"
  12.             End If
  13.         Else
  14.             If rng Mod 2 <> 0 Then
  15.                 str = str & rng & ";"
  16.             End If
  17.         End If
  18.     Next
  19.     作业1 = Left(str, Len(str) - 1)
  20. End Function
复制代码

作业2 星座
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim rng As Range, area As Range, i As Long, fAddress As String
  3.     If Target.Address(0, 0) = "B1" Then
  4.         Range("A4:D13").ClearContents
  5.         With Worksheets("sheet1")
  6.             Set area = .Range("a1").CurrentRegion
  7.             Set rng = area.Find(Range("B1"))
  8.             fAddress = rng.Address
  9.             i = 4
  10.             Do While Not rng Is Nothing
  11.                 area.Rows(rng.Row).Copy Cells(i, 1)
  12.                 Set rng = area.FindNext(rng)
  13.                 If rng.Address = fAddress Then Exit Do
  14.                 i = i + 1
  15.             Loop
  16.         End With
  17.     End If
  18. End Sub
复制代码

作业3 聚光灯
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     Dim rng As Range, area As Range
  3.     Set area = Range("A1").CurrentRegion
  4.     If Not Intersect(Target, area) Is Nothing Then
  5.         area.Interior.Color = xlNone
  6.         area.Rows(Target.Row).Interior.Color = vbYellow
  7.         area.Columns(Target.Column).Interior.Color = vbYellow
  8.     End If
  9. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2017-6-6 22:19:10 | 显示全部楼层
  1. Public Function myget(area As Range)
  2.     Dim rng As Range
  3.     Dim qs, os As Long
  4.     Dim qs_str, os_str As String
  5.     For Each rng In area
  6.         If rng Mod 2 = 1 Then
  7.            qs = qs + 1
  8.            If qs_str = "" Then
  9.                 qs_str = rng
  10.             Else
  11.                qs_str = qs_str & ";" & rng
  12.             End If
  13.         Else
  14.             os = os + 1
  15.            If os_str = "" Then
  16.                 os_str = rng
  17.             Else
  18.                os_str = os_str & ";" & rng
  19.             End If
  20.         End If
  21.     Next
  22.     If qs > os Then
  23.         myget = qs_str
  24.     Else
  25.         myget = os_str
  26.         
  27.     End If
  28. End Function
复制代码


覃晓晴作业1,求奇偶数
回复 支持 反对

使用道具 举报

发表于 2017-6-6 23:03:45 | 显示全部楼层
覃晓晴 作业:聚光灯作业

  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     Dim rng, han, lie As Range
  3.     Dim myRow, myColumn As Long
  4.     Set rng = [a1].CurrentRegion
  5.     If Not Intersect(Target, rng) Is Nothing Then
  6.         myRow = rng.Rows.count
  7.         myColumn = rng.Columns.count
  8.         Set han = Range(Cells(Target.Row, 1), Cells(Target.Row, myColumn))    '定义聚光灯行区域
  9.         Set lie = Range(Cells(1, Target.Column), Cells(myRow, Target.Column)) '定义聚光灯列区域
  10.         Cells.Interior.ColorIndex = xlNone
  11.         han.Interior.Color = vbYellow  '行变黄
  12.         lie.Interior.Color = vbYellow   '列变黄
  13.         Target.Interior.Color = vbRed   '当前变红
  14.     Else
  15.        Cells.Interior.ColorIndex = xlNone   '当所点单元格不在区域中,取消整表的颜色
  16.     End If
  17. End Sub
复制代码

回复 支持 反对

使用道具 举报

发表于 2017-6-8 00:44:40 | 显示全部楼层
作业1 聚光灯
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.             Dim area As Range, i As Long
  3.             Cells.Interior.Color = xlNone
  4.             Set area = Sheet1.Range("a1").CurrentRegion
  5.             If Target.count > 1 Then
  6.                         Exit Sub
  7.             ElseIf Target.Row > area.Rows.count Or Target.Column > area.Columns.count Then
  8.                         Exit Sub
  9.             Else
  10.                         For i = 1 To area.Columns.count
  11.                                     Cells(Target.Row, i).Interior.Color = vbYellow
  12.                         Next
  13.                         For i = 1 To area.Rows.count
  14.                                     Cells(i, Target.Column).Interior.Color = vbYellow
  15.                         Next
  16.             End If
  17. End Sub
复制代码
第2题 自定义函数
  1. Function getvalue(ByVal area As Range)
  2.             Dim i As Long, odd As Long, even As Long, str As String, str1 As String
  3.             For i = 1 To 3
  4.                         If area.Cells(1, i) Mod 2 = 0 Then
  5.                                     even = even + 1
  6.                                     str = str & area.Cells(1, i) & ";"
  7.                         Else
  8.                                     odd = odd + 1
  9.                                     str1 = str1 & area.Cells(1, i) & ";"
  10.                         End If
  11.             Next
  12.             If Right(str, 1) = ";" Then str = Left(str, Len(str) - 1)
  13.             If Right(str1, 1) = ";" Then str1 = Left(str1, Len(str1) - 1)
  14.             If even > odd Then
  15.                         getvalue = str
  16.             Else
  17.                         getvalue = str1
  18.             End If
  19. End Function
复制代码
第3题 星座
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.             If Target.Address(0, 0) <> "B1" Then Exit Sub
  3.             Dim area As Range, rng As Range
  4.             Set area = Worksheets("sheet1").Range("a1").CurrentRegion.Offset(1, 0)
  5.             Set area = area.Resize(area.Rows.Count - 1)
  6.             Sheet2.Range("a3").CurrentRegion.ClearContents
  7.             area.AutoFilter 4, Sheet2.Range("b1").Value
  8.             area.SpecialCells(xlCellTypeVisible).Copy Sheet2.Range("a3")
  9. End Sub
复制代码


回复 支持 反对

使用道具 举报

发表于 2017-6-12 10:59:15 | 显示全部楼层
  1. Function 填多的类数(findarea As Range) As String
  2.     Dim fx As Range, i%, j%
  3.     For Each fx In findarea
  4.         If fx Mod 2 <> 0 Then
  5.             i = i + 1
  6.         Else
  7.             j = j + 1
  8.         End If
  9.     Next
  10.         If i > j Then
  11.                 For Each fx In findarea
  12.                     If fx Mod 2 <> 0 Then 填多的类数 = 填多的类数 & ";" & fx
  13.                 Next
  14.         Else
  15.                 For Each fx In findarea
  16.                     If fx Mod 2 = 0 Then 填多的类数 = 填多的类数 & ";" & fx
  17.                 Next
  18.         End If
  19.         填多的类数 = Right(填多的类数, Len(填多的类数) - 1)
  20. End Function
复制代码
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim i&, j&
  3.     j = 4
  4.     Target = Range("b1")
  5.     Range("a4:d" & Range("d3").CurrentRegion.Rows.Count).ClearComments
  6.     For i = 2 To Sheet1.UsedRange.Rows.Count
  7.         If Sheet1.Cells(i, 4) = Target Then
  8.             Sheet1.Cells(i, 4).Resize(0, -4).Copy Cells(j, 1)
  9.             j = j + 1
  10.         End If
  11.     Next
  12. End Sub
复制代码
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     Dim mrow%, mcol%
  3.     mrow = Range("a1").CurrentRegion.Rows.count
  4.     mcol = Range("a1").CurrentRegion.Columns.count
  5.     Cells.Interior.Color = xlNone
  6.     If Target.count > 1 Or Target.Row > mrow Or Target.Column > mcol Then Exit Sub '选择一个区域或超出边界没有任何反应
  7.    Range(Cells(Target.Row, 1), Cells(Target.Row, mcol)).Interior.Color = vbYellow
  8.    Range(Cells(1, Target.Column), Cells(mrow, Target.Column)).Interior.Color = vbYellow
  9. End Sub
复制代码


回复 支持 反对

使用道具 举报

发表于 2017-6-12 17:13:36 | 显示全部楼层
  1. '第14课作业_聚光灯
  2. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  3.     Cells.Interior.Color = xlNone
  4.     If Target.Column <= 8 And Target.Row <= [a1].CurrentRegion.Rows.count Then
  5.     Target.End(xlToLeft).Resize(1, 8).Interior.Color = vbYellow
  6.     Target.End(xlUp).Resize([a1].CurrentRegion.Rows.count, 1).Interior.Color = vbYellow
  7.     End If
  8. End Sub

  9. '第14课作业_星座
  10. Private Sub Worksheet_Change(ByVal Target As Range)
  11.     Application.EnableEvents = False
  12.     Dim i As Long
  13.     Dim j As Long
  14.     j = 4
  15.     Range("a4:d13").ClearContents
  16.     If Target.Address = "$B$1" Then
  17.         For i = 3 To Worksheets("Sheet1").Range("a1").CurrentRegion.Rows.Count
  18.             If Target = Worksheets("Sheet1").Range("d" & i) Then
  19.                 Worksheets("Sheet1").Range("a" & i, "d" & i).Copy Worksheets("事件响应作业").Range("a" & j, "d" & j)
  20.                 j = j + 1
  21.             End If
  22.         Next
  23.     End If
  24.     Application.EnableEvents = True
  25. End Sub
复制代码


回复 支持 反对

使用道具 举报

发表于 2017-6-13 16:29:46 | 显示全部楼层
  1. Function union(rng1 As Range, rng2 As Range, rng3 As Range)
  2. '判断每个单元格奇偶数出现的次数,统计次数
  3.     Dim 偶数次数 As Long, 奇数次数 As Long
  4.     If rng1 Mod 2 = 0 Then
  5.         偶数次数 = 偶数次数 + 1
  6.     Else
  7.         奇数次数 = 奇数次数 + 1
  8.     End If
  9.     If rng2 Mod 2 = 0 Then
  10.         偶数次数 = 偶数次数 + 1
  11.     Else
  12.         奇数次数 = 奇数次数 + 1
  13.     End If
  14.     If rng3 Mod 2 = 0 Then
  15.         偶数次数 = 偶数次数 + 1
  16.     Else
  17.         奇数次数 = 奇数次数 + 1
  18.     End If
  19. '根据统计的奇偶数情况,判断偶数多还是奇数多
  20.     Select Case 偶数次数
  21.         Case Is = 3
  22.             union = rng1 & ";" & rng2 & ";" & rng3
  23.         Case Is = 2 And (rng1 + rng2) Mod 2 = 0
  24.             union = rng1 & ";" & rng2
  25.         Case Is = 2 And (rng2 + rng3) Mod 2 = 0
  26.             union = rng2 & ";" & rng3
  27.         Case Is = 2 And (rng1 + rng3) Mod 2 = 0
  28.             union = rng1 & ";" & rng3
  29.         Case Is = 1 And (rng1 + rng2) Mod 2 = 0
  30.             union = rng1 & ";" & rng2
  31.         Case Is = 1 And (rng2 + rng3) Mod 2 = 0
  32.             union = rng2 & ";" & rng3
  33.         Case Is = 1 And (rng1 + rng3) Mod 2 = 0
  34.             union = rng1 & ";" & rng3
  35.         Case Else
  36.             union = rng1 & ";" & rng2 & ";" & rng3
  37.         End Select
  38. End Function
复制代码
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     Dim area As Range, rng As Range, area1 As Range
  3.     Cells.Interior.Color = xlNone
  4.     If Target.Column > Range("h:h").Column Then Exit Sub
  5.     If Target.Row > 204 Then Exit Sub
  6.     If Target.count > 1 Then Exit Sub
  7.     Target.Interior.Color = vbYellow
  8.     Set rng = Range("a1").CurrentRegion
  9.     Set area = Union(Target.EntireColumn, Target.EntireRow)
  10.     Set area1 = Intersect(rng, area)
  11.     area1.Interior.Color = vbYellow
  12.     Target.Interior.Color = vbRed
  13. End Sub
复制代码


回复 支持 反对

使用道具 举报

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

本版积分规则

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