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

# 零基础13期-第十六课作业 发表于 2018-4-30 15:47:16 | 显示全部楼层 |阅读模式
 规则如前 发表于 2018-4-30 18:11:56 | 显示全部楼层
 本帖最后由 door19 于 2018-4-30 18:15 编辑 '作业1 Private Sub Worksheet_Change(ByVal TARGET As Range) Dim I As Long, ADF As String, RNG As Range, J As Long, area As Range J = 3     If TARGET.Address(0, 0) <> "B1" Then Exit Sub     Range("a4", "d13").ClearContents     Set area = Sheets("sheet1").[a1].CurrentRegion     Set RNG = area.Find(TARGET)     ADF = RNG.Address         For I = 3 To 12             If RNG = TARGET Then                 J = J + 1                 Range("D" & J) = TARGET                 Range("C" & J) = RNG.Offset(0, -1)                 Range("B" & J) = RNG.Offset(0, -2)                 Range("A" & J) = RNG.Offset(0, -3)                 Set RNG = area.FindNext(RNG)                     If RNG.Address = ADF Then Exit Sub             End If         Next End Sub复制代码'作业2 Private Sub Worksheet_Change(ByVal target As Range) Dim j As Long, i As Long j = 6 If target.Address(0, 0) <> "C3" Then Exit Sub Else Range("b7", "e20").ClearContents     For i = 2 To Sheets("出入库清单").[a1].CurrentRegion.Rows.Count         With Sheets("出入库清单")         If [c3] = .Cells(i, 5) Then             j = j + 1             Cells(j, 2) = .Cells(i, 4)             Cells(j, 4) = .Cells(i, "j")             Cells(j, 5) = .Cells(i, "g")         End If         End With Next End If End Sub复制代码 发表于 2018-5-4 21:31:52 | 显示全部楼层
 '星座 Private Sub Worksheet_Change(ByVal Target As Range)     Dim FindName As String, rng As Range, area As Range, FirstNm     If Target.Address(0, 0) <> "B1" Then Exit Sub     Range("a3").CurrentRegion.Offset(1, 0).ClearContents     Set area = Worksheets("sheet1").[a2].CurrentRegion     Set rng = area.Find(Target)         If Not rng Is Nothing Then         FirstNm = rng.Address         i = 0         Do             rng.Offset(0, -3).Resize(1, 4).Copy Worksheets("事件响应作业").Cells(i + 4, 1)             Set rng = area.FindNext(rng)             i = i + 1         Loop While FirstNm <> rng.Address     End If End Sub ======================== Private Sub Worksheet_Change(ByVal Target As Range)     Dim area As Range, First As String, rng As Range, rk As Long, ck As Long     Application.EnableEvents = False     If Target.Address(0, 0) <> "C2" Then Exit Sub     Range([a7], Cells(Rows.Count, "f").End(xlUp)).Clear     Set area = Worksheets("出入库清单").[A1].CurrentRegion     Set rng = area.Find(Target)     Range("c3") = rng.Offset(0, -1)     If Not rng Is Nothing Then         First = rng.Address         i = 0         Do             If rng.Offset(0, 4) = "" Then                 rng.Offset(0, -2).Copy Cells(i + 7, "b")                 rng.Offset(0, 1).Copy Cells(i + 7, "e")                 ck = ck + Cells(i + 7, "e")             Else                 rng.Offset(0, -2).Copy Cells(i + 7, "b")                 rng.Offset(0, 4).Copy Cells(i + 7, "d")                 rk = rk + Cells(i + 7, "d")             End If            Cells(i + 7, "a") = i + 1            Cells(i + 7, "f") = [f6] + rk - ck            Set rng = area.FindNext(rng)             i = i + 1         Loop While First <> rng.Address     End If     Cells(Rows.Count, "a").End(xlUp).Offset(2, 0) = "合计"     Cells(Rows.Count, "a").End(xlUp).Offset(0, 3) = rk     Cells(Rows.Count, "a").End(xlUp).Offset(0, 4) = ck     Cells(Rows.Count, "a").End(xlUp).Offset(0, 5) = [f6] + rk - ck     With Range([a7], Cells(Rows.Count, "f").End(xlUp))         .Borders(xlEdgeBottom).LineStyle = xlContinuous         .Borders(xlEdgeLeft).LineStyle = xlContinuous         .Borders(xlEdgeRight).LineStyle = xlContinuous         .Borders(xlEdgeTop).LineStyle = xlContinuous         .Borders(xlInsideHorizontal).LineStyle = xlContinuous         .Borders(xlInsideVertical).LineStyle = xlContinuous     End With     Application.EnableEvents = True End Sub复制代码

 本版积分规则 回帖后跳转到最后一页

### 官方微博

• 新浪官方微博: @ExcelHome

### 官方微信

• 微信公众号: iexcelhome