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

零基础13期-第十六课作业

[复制链接]
发表于 2018-4-30 15:47:16 | 显示全部楼层 |阅读模式
回复

使用道具 举报

发表于 2018-4-30 18:11:56 | 显示全部楼层
本帖最后由 door19 于 2018-4-30 18:15 编辑
  1. '作业1
  2. Private Sub Worksheet_Change(ByVal TARGET As Range)
  3. Dim I As Long, ADF As String, RNG As Range, J As Long, area As Range
  4. J = 3
  5.     If TARGET.Address(0, 0) <> "B1" Then Exit Sub
  6.     Range("a4", "d13").ClearContents
  7.     Set area = Sheets("sheet1").[a1].CurrentRegion
  8.     Set RNG = area.Find(TARGET)
  9.     ADF = RNG.Address
  10.         For I = 3 To 12
  11.             If RNG = TARGET Then
  12.                 J = J + 1
  13.                 Range("D" & J) = TARGET
  14.                 Range("C" & J) = RNG.Offset(0, -1)
  15.                 Range("B" & J) = RNG.Offset(0, -2)
  16.                 Range("A" & J) = RNG.Offset(0, -3)
  17.                 Set RNG = area.FindNext(RNG)
  18.                     If RNG.Address = ADF Then Exit Sub
  19.             End If
  20.         Next
  21. End Sub
复制代码
  1. '作业2
  2. Private Sub Worksheet_Change(ByVal target As Range)
  3. Dim j As Long, i As Long
  4. j = 6
  5. If target.Address(0, 0) <> "C3" Then
  6. Exit Sub
  7. Else
  8. Range("b7", "e20").ClearContents
  9.     For i = 2 To Sheets("出入库清单").[a1].CurrentRegion.Rows.Count
  10.         With Sheets("出入库清单")
  11.         If [c3] = .Cells(i, 5) Then
  12.             j = j + 1
  13.             Cells(j, 2) = .Cells(i, 4)
  14.             Cells(j, 4) = .Cells(i, "j")
  15.             Cells(j, 5) = .Cells(i, "g")
  16.         End If
  17.         End With
  18. Next
  19. End If
  20. End Sub
复制代码


回复 支持 反对

使用道具 举报

发表于 2018-5-4 21:31:52 | 显示全部楼层
  1. '星座
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3.     Dim FindName As String, rng As Range, area As Range, FirstNm
  4.     If Target.Address(0, 0) <> "B1" Then Exit Sub
  5.     Range("a3").CurrentRegion.Offset(1, 0).ClearContents
  6.     Set area = Worksheets("sheet1").[a2].CurrentRegion
  7.     Set rng = area.Find(Target)
  8.    
  9.     If Not rng Is Nothing Then
  10.         FirstNm = rng.Address
  11.         i = 0
  12.         Do
  13.             rng.Offset(0, -3).Resize(1, 4).Copy Worksheets("事件响应作业").Cells(i + 4, 1)
  14.             Set rng = area.FindNext(rng)
  15.             i = i + 1
  16.         Loop While FirstNm <> rng.Address
  17.     End If

  18. End Sub

  19. ========================
  20. Private Sub Worksheet_Change(ByVal Target As Range)
  21.     Dim area As Range, First As String, rng As Range, rk As Long, ck As Long
  22.     Application.EnableEvents = False
  23.     If Target.Address(0, 0) <> "C2" Then Exit Sub
  24.     Range([a7], Cells(Rows.Count, "f").End(xlUp)).Clear
  25.     Set area = Worksheets("出入库清单").[A1].CurrentRegion
  26.     Set rng = area.Find(Target)
  27.     Range("c3") = rng.Offset(0, -1)
  28.     If Not rng Is Nothing Then
  29.         First = rng.Address
  30.         i = 0
  31.         Do
  32.             If rng.Offset(0, 4) = "" Then
  33.                 rng.Offset(0, -2).Copy Cells(i + 7, "b")
  34.                 rng.Offset(0, 1).Copy Cells(i + 7, "e")
  35.                 ck = ck + Cells(i + 7, "e")
  36.             Else
  37.                 rng.Offset(0, -2).Copy Cells(i + 7, "b")
  38.                 rng.Offset(0, 4).Copy Cells(i + 7, "d")
  39.                 rk = rk + Cells(i + 7, "d")
  40.             End If
  41.            Cells(i + 7, "a") = i + 1
  42.            Cells(i + 7, "f") = [f6] + rk - ck
  43.            Set rng = area.FindNext(rng)
  44.             i = i + 1
  45.         Loop While First <> rng.Address
  46.     End If
  47.     Cells(Rows.Count, "a").End(xlUp).Offset(2, 0) = "合计"
  48.     Cells(Rows.Count, "a").End(xlUp).Offset(0, 3) = rk
  49.     Cells(Rows.Count, "a").End(xlUp).Offset(0, 4) = ck
  50.     Cells(Rows.Count, "a").End(xlUp).Offset(0, 5) = [f6] + rk - ck
  51.     With Range([a7], Cells(Rows.Count, "f").End(xlUp))
  52.         .Borders(xlEdgeBottom).LineStyle = xlContinuous
  53.         .Borders(xlEdgeLeft).LineStyle = xlContinuous
  54.         .Borders(xlEdgeRight).LineStyle = xlContinuous
  55.         .Borders(xlEdgeTop).LineStyle = xlContinuous
  56.         .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  57.         .Borders(xlInsideVertical).LineStyle = xlContinuous
  58.     End With
  59.     Application.EnableEvents = True
  60. End Sub
复制代码
回复 支持 反对

使用道具 举报

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

本版积分规则

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