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

零基础9期 第十五课作业贴

[复制链接]
发表于 2017-3-17 09:08:42 | 显示全部楼层 |阅读模式
本帖最后由 唐伯狼 于 2017-4-11 16:58 编辑

老规矩
老规矩
老规矩
回复

使用道具 举报

发表于 2017-3-18 21:33:34 | 显示全部楼层
本帖最后由 索尔来了 于 2017-3-18 22:18 编辑
  1. '作业2:完成聚光灯代码
  2. '1、选中单元格区域不可以超过1行和1列
  3. '2、聚光灯横向黄色,纵向红色,但是不可以超过[a1].currentregion
  4. '3、如果选择有效区域之外的单元格,代码不响应
  5. '4、每次点击的时候之前的聚光灯效果自动被清除
  6. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  7.     Dim m, n As Long

  8.     With Target
  9.         m = .CurrentRegion.Rows.Count
  10.         n = .CurrentRegion.Columns.Count
  11.     End With
  12.     Cells.Interior.ColorIndex = xlNone
  13.     If Target.Row > m Or Target.Column > n Then
  14.         Exit Sub
  15.     Else
  16.         With Target.CurrentRegion
  17.             .Columns(Target.Column).Interior.ColorIndex = 4
  18.             .Rows(Target.Row).Interior.ColorIndex = 3
  19.         End With
  20.     End If
  21. End Sub


  22. Private Sub Worksheet_Change(ByVal Target As Range)
  23.     If Target.Address = "$B$1" Then
  24.         Debug.Print Target.Value
  25.         Dim i, j As Long
  26.         j = 3
  27.         Worksheets(2).Range("A4:D20").ClearContents '事件响应作业的工作表内容清空
  28.         With Worksheets(1)
  29.             For i = 3 To .Range("A" & Rows.Count).End(xlUp).Row '根据人数多少进行循环
  30.                 If .Range("D" & i) = Target Then
  31.                     j = j + 1 '设置需要粘贴所在表的行数
  32.                     .Range("D" & i).Offset(0, -3).Resize(1, 4).Copy _
  33.                     Worksheets(2).Range("A" & j) '将源数据的整行数据粘贴到时间相应作业中
  34.                 End If
  35.             Next
  36.         End With
  37.     End If
  38. End Sub
复制代码


回复 支持 反对

使用道具 举报

发表于 2017-3-19 00:08:04 | 显示全部楼层
本帖最后由 chenglian99 于 2017-3-21 21:23 编辑
  1. '作业2:完成聚光灯代码
  2. '1、选中单元格区域不可以超过1行和1列
  3. '2、聚光灯横向黄色,纵向红色,但是不可以超过[a1].currentregion
  4. '3、如果选择有效区域之外的单元格,代码不响应
  5. '4、每次点击的时候之前的聚光灯效果自动被清除
  6. '工作表的默认事件,响应工作表上的单元格被选中
  7. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  8.     Dim R As Long, C As Long, maxR As Long, maxC As Long, tarR As Long, tarC As Long
  9.     Cells.Interior.Color = xlNone                                         '清除工作表中所有单元格的背景色
  10.     R = Target.Rows.Count
  11.     C = Target.Columns.Count                                              '统计target行R、列C
  12.     maxR = Range("a1").CurrentRegion.Rows.Count
  13.     maxC = Range("a1").CurrentRegion.Columns.Count                        '统计[A1]单元格所在连续区域行、列数
  14.     tarR = Target.Row
  15.     tarC = Target.Column                                                  'target所在行号 、列号
  16.     If R = 1 And C = 1 And tarR <= maxR And tarC <= maxC Then             '条件:选中单元格行S=1 列S=1 and 选中单元格不能超出[a1].currentregion
  17.         Range(Cells(tarR, 1), Cells(tarR, maxC)).Interior.Color = vbYellow
  18.         Range(Cells(1, tarC), Cells(maxR, tarC)).Interior.Color = vbRed   '结果:设置选中行填充yellow,列填充red
  19.         Target.Interior.Color = xlNone
  20.     End If
  21. End Sub


  22. 星座数据自动提取
  23. Private Sub Worksheet_Change(ByVal Target As Range)
  24.     Dim sht1 As Worksheet, sht2 As Worksheet, i As Long, j As Long, k As Long
  25.     Set sht1 = Worksheets("Sheet1")
  26.     Set sht2 = Worksheets("事件响应作业")
  27.     If Target.Address = "$B$1" Then                               '当触发B1时
  28.         sht2.Range("a4:d13").ClearContents                        '清除 a4:d13
  29.         i = 3
  30.         For j = 3 To 12
  31.                 If sht1.Range("d" & j) = Target Then              '判断数据单元格匹配
  32.                     i = i + 1
  33.                     sht1.Range("d" & j).Copy sht2.Range("d" & i)  '赋值到表格
  34.                     sht1.Range("d" & j).Offset(0, -1).Copy sht2.Range("d" & i).Offset(0, -1)
  35.                     sht1.Range("d" & j).Offset(0, -2).Copy sht2.Range("d" & i).Offset(0, -2)
  36.                     sht1.Range("d" & j).Offset(0, -3).Copy sht2.Range("d" & i).Offset(0, -3)
  37.                 End If
  38.         Next
  39.     End If
  40. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2017-3-19 00:33:32 | 显示全部楼层
本帖最后由 尛尛淼骉 于 2017-3-19 00:34 编辑
  1. '聚光灯
  2. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  3.     If Target.Columns.Count = 1 And Target.Rows.Count = 1 Then
  4.         Cells.Interior.Color = xlNone
  5.         Intersect(Target.EntireColumn, Target.CurrentRegion).Interior.Color = vbRed
  6.         Intersect(Target.EntireRow, Target.CurrentRegion).Interior.Color = vbYellow
  7.         Target.Interior.Color = xlNone
  8.     Else
  9.          Cells.Interior.Color = xlNone
  10.     End If
  11. End Sub
复制代码


  1. '星座
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3.     Dim i As Long, count As Long
  4.     If Target.Address = "$B$1" Then  '只对表格中的B1单元格的change事件作出响应
  5.         Range("A4:D4", Range("A4:D4").End(xlDown)).ClearContents
  6.         With Worksheets("sheet1")
  7.           count = 4 'count作为计数器,判断下一条记录的写入位置
  8.             For i = 3 To .Range("a1").CurrentRegion.Rows.count
  9.                   If .Cells(i, 4) = Target Then
  10.                     Intersect(.Rows(i), .Range("a1").CurrentRegion).Copy Range("a" & count)   '将满足条件的记录复制到指定位置
  11.                     count = count + 1
  12.                 End If
  13.             Next
  14.         End With
  15.         
  16.     End If
  17. End Sub
复制代码

回复 支持 反对

使用道具 举报

发表于 2017-3-19 12:01:17 | 显示全部楼层
本帖最后由 haidai@13 于 2017-3-19 18:25 编辑
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     Dim RNG1 As Range
  3.     Set RNG1 = Range("A1").CurrentRegion
  4.      Cells.Interior.Color = xlNone
  5.     If Target.Rows.Count > 1 Or Target.Columns.Count > 1 Then
  6.         Exit Sub
  7.     Else
  8.         Intersect(RNG1, Target.EntireRow).Interior.Color = vbYellow
  9.         Intersect(RNG1, Target.EntireColumn).Interior.Color = vbRed
  10.     End If
  11. End Sub
复制代码

  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Application.EnableEvents = False
  3.     Dim RNG As Range, area As Range, FADDRESS As String, i As Integer
  4.      i = 4
  5.     If Target = Range("b1") Then
  6.          [a4].CurrentRegion.ClearContents
  7.         Set Target = [b1]
  8.         Set area = Worksheets("sheet1").[A2].CurrentRegion
  9.         Set RNG = area.Find([b1])
  10.         If Not RNG Is Nothing Then
  11.             FADDRESS = RNG.Address
  12.             Do
  13.             Set RNG = area.FindNext(RNG)
  14.            RNG.Offset(0, -3).Resize(1, 4).Copy Cells(i, "A")
  15.              i = i + 1
  16.               Loop Until FADDRESS = RNG.Address
  17.        End If
  18.     End If
  19.     Application.EnableEvents = True
  20. End Sub
复制代码

回复 支持 反对

使用道具 举报

发表于 2017-3-19 16:39:22 | 显示全部楼层
学员:低调的小兵作业一:
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     Dim ran As Range
  3.     Set ran = Intersect(Range("A1").CurrentRegion, Target)
  4.     If Not ran Is Nothing And Target.Count = 1 Then
  5.         Cells.Interior.Color = xlNone
  6.         Intersect(ran.EntireRow, Range("A1").CurrentRegion).Interior.Color = vbYellow
  7.         Intersect(ran.EntireColumn, Range("A1").CurrentRegion).Interior.Color = vbRed
  8.         ran.Interior.Color = vbBlue
  9.     End If
  10. End Sub
复制代码
作业二:
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim i As Long, j As Long
  3.     If Target.Address = "$B$1" Then
  4.         Range("A4", Range("D4").End(xlDown)).ClearContents
  5.         For i = 3 To Worksheets("SHEET1").Range("A2").CurrentRegion.Rows.Count
  6.             If Worksheets("SHEET1").Range("d" & i) = Range("B1") Then
  7.                 Worksheets("SHEET1").Range("d" & i).Offset(, -3).Resize(1, 4).Copy
  8.                 Range("A" & j + 4).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  9.        :=False, Transpose:=False
  10.                 j = j + 1
  11.             End If
  12.         Next
  13.     End If
  14. End Sub
复制代码


回复 支持 反对

使用道具 举报

发表于 2017-3-19 20:43:31 | 显示全部楼层
本帖最后由 cyxnry 于 2017-3-19 21:44 编辑
  1. Private Sub Worksheet_Change(ByVal target As Range)
  2.     Application.EnableEvents = False
  3.     If target = Range("B1") Then
  4.         Range("a3:d13").ClearContents
  5.         With Worksheets("SHEET1")
  6.             .[2:2].AutoFilter Field:=4, Criteria1:=Worksheets("事件响应作业").[b1]
  7.             .[a3].CurrentRegion.Copy
  8.             [a3].Select
  9.             ActiveSheet.Paste
  10.             .[2:2].AutoFilter
  11.         End With
  12.     End If
  13.     Application.EnableEvents = True
  14. End Sub
复制代码
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.    
  3.     Cells.Interior.Color = xlNone
  4.    
  5.     If Target.Columns.Count <> 1 Or Target.Rows.Count <> 1 Then
  6.         Exit Sub
  7.     ElseIf Intersect([a1].CurrentRegion, Target) Is Nothing Then
  8.         Exit Sub
  9.    
  10.     Else
  11.         
  12.         Intersect([a1].CurrentRegion, Range(Target.Row & ":" & Target.Row)).Interior.Color = vbYellow
  13.         Intersect([a1].CurrentRegion, Target.EntireColumn).Interior.Color = vbRed
  14.         Target.Interior.Color = vbMagenta
  15.    
  16.     End If
  17.    
  18.                
  19. End Sub
复制代码

回复 支持 反对

使用道具 举报

发表于 2017-3-20 16:30:24 | 显示全部楼层
  1. 第一题 聚光灯:
  2. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  3.     Dim rg1 As Range
  4.     Dim rg2 As Range
  5.     Dim rg3 As Range
  6.     Dim rg4 As Range
  7.     Sheet1.UsedRange.Interior.Color = xlNone
  8.     Set rg1 = Cells(Target.Row, 1)
  9.     Set rg2 = Cells(Target.Row, Range("a1").CurrentRegion.Columns.Count)
  10.     Set rg3 = Cells(1, Target.Column)
  11.     Set rg4 = Cells(Range("a1").CurrentRegion.Rows.Count, Target.Column)
  12.     If Not Target.Address(0, 0) Like "*:*" Then
  13.         If Target.Row <= Range("a1").CurrentRegion.Rows.Count And Target.Column <= Range("a1").CurrentRegion.Columns.Count Then
  14.             Range(rg1, rg2).Interior.Color = vbYellow
  15.             Range(rg3, rg4).Interior.Color = vbRed
  16.         Else
  17.             MsgBox "选择的单元格在范围外"
  18.         End If
  19.     Else
  20.         MsgBox "请选择一个单元格"
  21.     End If
  22. End Sub
复制代码
  1. 第二题 星座:
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3.     Application.EnableEvents = False
  4.     Dim i As Long
  5.     Dim j As Long
  6.     j = 4
  7.     Range("a4:d13").ClearContents
  8.     If Target.Address = "$B$1" Then
  9.         For i = 3 To Worksheets("Sheet1").Range("a1").CurrentRegion.Rows.Count
  10.             If Target = Worksheets("Sheet1").Range("d" & i) Then
  11.                 Worksheets("Sheet1").Range("a" & i, "d" & i).Copy Worksheets("事件响应作业").Range("a" & j, "d" & j)
  12.                 j = j + 1
  13.             End If
  14.         Next
  15.     Else
  16.         MsgBox "请在B1单元格中选择"
  17.     End If
  18.     Application.EnableEvents = True
  19. End Sub
复制代码


回复 支持 反对

使用道具 举报

发表于 2017-3-26 14:12:52 | 显示全部楼层
本帖最后由 晓黛清寒 于 2017-3-26 14:14 编辑
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     Cells.Interior.Color = xlNone '清除工作表中所有单元格的背景色
  3.     If Target.Column <= 8 And Target.Row <= [a1].CurrentRegion.Rows.Count Then
  4.     Target.End(xlToLeft).Resize(1, 8).Interior.Color = vbYellow
  5.     Target.End(xlUp).Resize([a1].CurrentRegion.Rows.Count, 1).Interior.Color = vbRed
  6.     End If
  7. End Sub
复制代码

'
  1. '作业2 星座
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3. Application.EnableEvents = False
  4. If Target = [b1] Then
  5.    Range("a4:d14").ClearContents
  6.    Dim i As Long, j As Long
  7.    For i = 3 To 12
  8.        If Sheet1.Range("d" & i) = Sheets("事件响应作业").Range("b1") Then
  9.        Sheet1.Range("d" & i).Offset(0, -3).Resize(1, 4).Copy
  10.        Sheets("事件响应作业").Select
  11.        Range("a" & j + 4).Select
  12.        ActiveSheet.Paste
  13.        j = j + 1
  14.       End If
  15.   Next
  16. End If
  17. Application.EnableEvents = True
  18. End Sub
复制代码

回复 支持 反对

使用道具 举报

发表于 2017-3-27 18:17:52 | 显示全部楼层
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     Cells.Interior.Color = xlNone
  3.     If Target.Rows.Count > 1 Or Target.Columns.Count > 1 Then
  4.         MsgBox "选中单元格区域不可以超过1行和1列"
  5.     ElseIf Not Application.Intersect([A1].CurrentRegion, Target) Is Nothing Then '判断一个单元格是否在区域中
  6.     'Application.Intersect([A1].CurrentRegion, Target) = Target '[A1].CurrentRegion可用usedrange判断,但该方法若target在空白区域,则程序报错
  7.         Range(Target.End(xlToLeft), Target.End(xlToRight)).Interior.Color = vbYellow
  8.         Range(Target.End(xlUp), Target.End(xlDown)).Interior.Color = vbRed
  9.     End If
  10. End Sub

  11. Private Sub Worksheet_Change(ByVal Target As Range)
  12.     If Target.Address = "$B$1" Then
  13.     '另一种限制触发的方法 Not Application.Intersect(Target, Range("B1")) Is Nothing
  14.         Range(Range("A4"), Range("A3").End(xlDown).End(xlToRight)).ClearContents '注意end的起点,若只有1行,end会导致整表被选中
  15.         With Sheet1
  16.         .Range("$A$2:$D$12").AutoFilter Field:=4, Criteria1:=Target.Value
  17.         .Range(.Range("A3"), .Range("A2").End(xlDown).End(xlToRight)).Copy Sheet2.Range("A4") '每个range都需要限定来自sheet1
  18.         End With
  19.     End If
  20. End Sub
复制代码
回复 支持 反对

使用道具 举报

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

本版积分规则

关闭

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

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