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

VBA实战开发第五期-第一课作业贴

[复制链接]
发表于 2018-5-9 19:40:04 | 显示全部楼层 |阅读模式
作业可以在这里回复,让大伙知道你很努力^_^
回复

使用道具 举报

发表于 2018-5-9 19:51:06 | 显示全部楼层
本帖最后由 door19 于 2018-5-9 19:54 编辑
  1. '作业1
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3.     If Target.Address(0, 0) <> "A2" Then
  4.         Exit Sub
  5.     End If
  6. Range([b2], [b2].End(xlDown).End(xlToRight)).ClearContents
  7. Dim sht As Worksheet, rng As Range, adrs As String, cnt As Long
  8.     cnt = 1
  9.     For Each sht In Worksheets
  10.         If sht.Name Like "*班" Then
  11.             Set rng = sht.[a1].CurrentRegion.Find(Target)
  12.                 If Not rng Is Nothing Then
  13.                     cnt = cnt + 1
  14.                     Sheet6.Cells(cnt, rng.Column + 2) = rng
  15.                         If rng.Column = 1 Then
  16.                             Sheet6.Cells(cnt, rng.Column + 2).Offset(0, 1) = rng.Offset(0, 1)
  17.                         Else
  18.                             Sheet6.Cells(cnt, rng.Column + 2).Offset(0, -1) = rng.Offset(0, -1)
  19.                         End If
  20.                     Sheet6.Cells(cnt, "B") = sht.Name
  21.                     adrs = rng.Address
  22.                         If sht.[a1].CurrentRegion.FindNext(rng).Address <> adrs Then
  23.                             Do
  24.                                 Set rng = sht.[a1].CurrentRegion.FindNext(rng)
  25.                                 cnt = cnt + 1
  26.                                 Sheet6.Cells(cnt, rng.Column + 2) = rng
  27.                                     If rng.Column = 1 Then
  28.                                         Sheet6.Cells(cnt, rng.Column + 2).Offset(0, 1) = rng.Offset(0, 1)
  29.                                     Else
  30.                                         Sheet6.Cells(cnt, rng.Column + 2).Offset(0, -1) = rng.Offset(0, -1)
  31.                                     End If
  32.                                 Sheet6.Cells(cnt, "B") = sht.Name
  33.                             Loop Until sht.[a1].CurrentRegion.FindNext(rng).Address = adrs
  34.                         End If
  35.                 End If
  36.         End If
  37.     Next
  38. End Sub
复制代码
  1. ‘作业2
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3. If Target.Address(0, 0) <> "F3" Then
  4. Exit Sub
  5. End If
  6. Range([A5], [BD33]).Interior.Color = xlNone
  7. Range([A5], [BD33]).Font.Color = vbBlack
  8. Dim aa As Range
  9. Dim ce1 As Range, ce2 As Range, ce3 As Range, cnt As Long
  10. Set aa = Sheet1.[a1].CurrentRegion.Find(Sheet2.Cells(3, "F"))
  11. For Each ce1 In Sheet1.Range(Sheet1.Cells(aa.Row, "d"), Sheet1.Cells(aa.Row, "l"))
  12.     If ce1 <> "" Then
  13.         For Each ce2 In Range("c8:bd8")
  14.             If ce2 = ce1 Then
  15.                 For Each ce3 In Range(Cells(10, ce2.Column), Cells(33, ce2.Column))
  16.                     If ce3 = aa.Offset(0, 1) Then
  17.                         cnt = cnt + 1
  18.                         ce3.Interior.Color = vbYellow
  19.                         ce3.Font.Color = vbRed
  20.                     End If
  21.                 Next
  22.             End If
  23.         Next
  24.     End If
  25. Next
  26. [y3] = cnt
  27. End Sub
复制代码
  1. '零基础毕业-班级课表
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3. Application.ScreenUpdating = False
  4. Dim x2 As Range, y2 As Range, x3 As Range, y3 As Range, king As Range, op As Range
  5. Dim cc As Range, zz As Range
  6.     If Target.Address(0, 0) <> "B3" And Target.Address(0, 0) <> "C3" Then
  7.     Exit Sub
  8.     End If
  9.     Range("D6:J11").ClearContents
  10.     Range("D13:J16").ClearContents
  11.     Range("D18:J23").ClearContents
  12.     Range("D25:J32").ClearContents
  13. Sheet2.Activate
  14.     With Sheet1
  15.         For Each op In Range([d5], [h5])
  16.             Set x3 = .Range(.[a3], .Cells(3, .[a1].CurrentRegion.Columns.Count)).Find(op)
  17.             Set y3 = .Range(.[a3], .Cells(3, .[a1].CurrentRegion.Columns.Count)).Find(op)
  18.                 Do
  19.                     Set y3 = .Range(.[a3], .Cells(3, .[a1].CurrentRegion.Columns.Count)).FindNext(y3)
  20.                 Loop Until .Range(.[a3], .Cells(3, .[a1].CurrentRegion.Columns.Count)).FindNext(y3).Address = x3.Address
  21.                 Set x2 = .Range(x3.Offset(1, -1), y3.Offset(1, 0)).Find([b3])
  22.                 Set y2 = .Range(x3.Offset(1, -1), y3.Offset(1, 0)).Find([b3])
  23.                     Do
  24.                         Set y2 = Sheet1.Range(x3.Offset(1, 0), y3.Offset(1, 0)).FindNext(y2)
  25.                     Loop Until .Range(x3.Offset(1, 0), y3.Offset(1, 0)).FindNext(y2).Address = x2.Address
  26.                     Set king = .Range(x2.Offset(1, -1), y2.Offset(1, 0)).Find([c3]).Offset(1, 0)
  27.                         For Each cc In Range([b6], [b32])
  28.                             For Each zz In .Range(.[a6], .[b19])
  29.                                 If cc = zz And cc <> "" And zz <> "" Then
  30.                                     Intersect(cc.EntireRow, op.EntireColumn) = Intersect(zz.EntireRow, king.EntireColumn)
  31.                                 End If
  32.                             Next
  33.                         Next
  34.         Next
  35.     End With
  36.         Dim x As Range, y As Range, king2 As Range, x1 As Range, y1 As Range
  37.             With Sheet5
  38.                 For Each x In .Range(.[b2], .[p2])
  39.                     For Each y In .Range(.[b3], .[p3])
  40.                         If x = [b3] And y = [c3] Then
  41.                             If x.Column = y.Column Then
  42.                                 Set king2 = .Range(x.Offset(2, 0), .Cells(.[a1].CurrentRegion.Rows.Count, x.Column))
  43.                                     For Each y1 In king2
  44.                                         For Each x1 In [a5].CurrentRegion
  45.                                             If x1 = .Cells(y1.Row, 1) Then
  46.                                                 x1.Offset(1, 0) = y1
  47.                                             End If
  48.                                         Next
  49.                                     Next
  50.                             End If
  51.                         End If
  52.                     Next
  53.                 Next
  54.             End With
  55. End Sub
复制代码
  1. ‘零基础毕业-个人课表
  2. Private Sub Worksheet_Change(ByVal Target As Range)
  3. Dim t As Range, b As Range, c As String
  4. Application.ScreenUpdating = False
  5.     If Target.Address(0, 0) <> "B3" Then
  6.     Exit Sub
  7.     ElseIf [b3] = "" Then
  8.     Range("D6:J11").ClearContents
  9.     Range("D13:J16").ClearContents
  10.     Range("D18:J23").ClearContents
  11.     Range("D25:J32").ClearContents
  12.     MsgBox "空白"
  13.     Exit Sub
  14.     End If
  15.     Range("D6:J11").ClearContents
  16.     Range("D13:J16").ClearContents
  17.     Range("D18:J23").ClearContents
  18.     Range("D25:J32").ClearContents
  19.         c = [b3]
  20.             For Each t In Sheet5.Range("b4:p19")
  21.                 If t = c Then
  22.                     With Sheet2
  23.                         .[b3] = Sheet5.Cells(2, t.Column)
  24.                             .[c3] = Sheet5.Cells(3, t.Column)
  25.                         End With
  26.                             With Sheet2
  27.                                 For Each b In .[a5].CurrentRegion
  28.                                     If b = c Then
  29.                                         Sheet3.Range(b.Address).Offset(-1, 0) = b.Offset(-1, 0)
  30.                                         Sheet3.Range(b.Address) = .[b3] & "年" & .[c3] & "班"
  31.                                     End If
  32.                                 Next
  33.                             End With
  34.                 End If
  35.             Next
  36. Sheet3.Activate
  37. End Sub
复制代码




回复 支持 反对

使用道具 举报

发表于 2018-5-9 19:58:05 | 显示全部楼层
本帖最后由 bolcom 于 2018-5-10 17:14 编辑
  1. Sub 动态数组()
  2. Dim arr, brr(), j%, n%
  3. arr = Sheet3.Range("a2", Sheet3.Cells(Rows.Count, 2).End(xlUp))
  4.     For j = LBound(arr) To UBound(arr)
  5.         If arr(j, 2) > 89 Then
  6.             n = n + 1
  7.             ReDim Preserve brr(1 To 2, 1 To n)
  8.             brr(1, n) = arr(j, 1)
  9.             brr(2, n) = arr(j, 2)
  10.         End If
  11.     Next
  12.     Sheet3.Range("d8").Resize(n, 2) = WorksheetFunction.Transpose(brr)
  13.     Sheet3.Range("i6") = n
  14. End Sub
复制代码
  1. Sub 重排()
  2. Dim arr, brr(), j%, n%, k%
  3.     With Sheet2
  4.         arr = .Range("a1", .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0))
  5.         k = 2
  6.         For j = 1 To UBound(arr)
  7.             If arr(j, 1) <> "" Then
  8.                 n = n + 1
  9.                 ReDim Preserve brr(1 To n)
  10.                 brr(n) = arr(j, 1)
  11.             Else
  12.                 If n = 0 Then GoTo line1
  13.                 k = k + 1
  14.                 .Cells(6, k).Resize(n, 1) = Application.Transpose(brr)
  15.                 ReDim brr(1 To 1)
  16.                 n = 0
  17.             End If
  18. line1:
  19.         Next
  20.     End With
  21. End Sub
复制代码
  1. Sub 转置()
  2. Dim arr
  3. arr = Sheet1.Range("a1:b7")
  4. Sheet1.Range("d1").Resize(2, UBound(arr)) = WorksheetFunction.Transpose(arr)
  5. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2018-5-10 17:22:00 | 显示全部楼层
  1. Sub 查询界面()
  2. Dim wsh As Worksheet, arr, brr(), crr(), drr, i%, j%, k%, n%
  3. ActiveSheet.Range("b2:d20").ClearContents
  4.     For Each wsh In Worksheets
  5.         If wsh.Name <> ActiveSheet.Name And Len(wsh.Name) = 2 Then
  6.             arr = wsh.Range("a2:b" & wsh.Cells(Rows.Count, 1).End(xlUp).Row)
  7.             n = 0
  8.             For i = 1 To UBound(arr)
  9.                 n = n + 1
  10.                 ReDim Preserve brr(1 To n)
  11.                 brr(n) = arr(i, 1) & "|" & arr(i, 2)
  12.             Next
  13.             drr = Filter(brr, ActiveSheet.[a2].Value)
  14.             For j = LBound(drr) To UBound(drr)
  15.                 k = k + 1
  16.                 ReDim Preserve crr(1 To 3, 1 To k)
  17.                 crr(1, k) = wsh.Name
  18.                 crr(2, k) = Split(drr(j), "|")(0)
  19.                 crr(3, k) = Split(drr(j), "|")(1)
  20.             Next
  21.         End If
  22.     Next
  23.     ActiveSheet.Range("b2").Resize(k, 3) = Application.Transpose(crr)
  24. End Sub
  25.             
复制代码
  1. Sub 排课()
  2. Dim rng1 As Range, rng2 As Range, kc As Range, rngs As Range, k$, cs%, rs%, a$, b$, srng As Range
  3. Set rng1 = Sheet2.Range("m3:u3")
  4. Set rng2 = Sheet2.Range("c8:bd8")
  5. k = Sheet2.Range("k3").Value
  6. Sheet2.Range("c10:bd33").Interior.ColorIndex = -4142
  7. Sheet2.Range("c10:bd33").Font.ColorIndex = -4105
  8.     For Each rng In rng1
  9.         If rng = 0 Then Exit For
  10.         For Each rn In rng2
  11.             If rn.Value = rng.Value Then
  12.                 cs = rn.Column: rs = rn.Row
  13.                 Set kc = Sheet2.Cells.Find(k, rn, , , xlByColumns, xlNext)
  14.                 a = kc.Address
  15.                 If rngs Is Nothing Then Set rngs = kc
  16.                     Do
  17.                         Set kc = Sheet2.Cells(rs, cs).EntireColumn.FindNext(kc)
  18.                         b = kc.Address
  19.                         Set rngs = Union(rngs, kc)
  20.                     Loop Until a = b
  21.             End If
  22.         Next
  23.     Next
  24.     rngs.Interior.ColorIndex = 10
  25.     rngs.Font.ColorIndex = 6
  26. End Sub
复制代码
  1. <p>Sub 班级课表()
  2. Dim rng1 As Range, rng2 As Range, rng3 As Range, wek As Range, wk As Range, mx As Range
  3. Dim i%, j%, n%, arr(), gran%, clan%
  4. On Error Resume Next
  5. gran = Sheet2.Range("b3"): clan = Sheet2.Range("c3")
  6. Set wek = Sheet2.Range("d5:h5")
  7.     For Each wk In wek
  8.         Set rng1 = Sheet1.Range("b3:by3").Find(wk.Value, , , , xlByRows, xlNext)
  9.         Set rng2 = Sheet1.Cells.Find(gran, rng1, , , xlByColumns, xlNext)
  10.         n = n + 1
  11.         For i = 1 To 14
  12.             ReDim Preserve arr(1 To 14, 1 To 5)
  13.             Set rng3 = Sheet1.Cells.Find(clan, rng2, , , xlByColumns, xlNext).Offset(i, 0)
  14.             arr(i, n) = rng3
  15.         Next
  16.     Next
  17.     For Each mx In Sheet2.Range("c6:c31")
  18.         If mx.Value = "课程" Then
  19. ling1:
  20.             j = j + 1
  21.             If arr(j, 1) = "" Then GoTo ling1
  22.             Sheet2.Cells(mx.Row, 4) = arr(j, 1)
  23.             Sheet2.Cells(mx.Row + 1, 4) = WorksheetFunction.VLookup(arr(j, 1), Sheet5.Range("a4:p20"), 列号, False)
  24.             Sheet2.Cells(mx.Row, 5) = arr(j, 2)
  25.             Sheet2.Cells(mx.Row + 1, 5) = WorksheetFunction.VLookup(arr(j, 2), Sheet5.Range("a4:p20"), 列号, False)
  26.             Sheet2.Cells(mx.Row, 6) = arr(j, 3)
  27.             Sheet2.Cells(mx.Row + 1, 6) = WorksheetFunction.VLookup(arr(j, 3), Sheet5.Range("a4:p20"), 列号, False)
  28.             Sheet2.Cells(mx.Row, 7) = arr(j, 4)
  29.             Sheet2.Cells(mx.Row + 1, 7) = WorksheetFunction.VLookup(arr(j, 4), Sheet5.Range("a4:p20"), 列号, False)
  30.             Sheet2.Cells(mx.Row, 8) = arr(j, 5)
  31.             Sheet2.Cells(mx.Row + 1, 8) = WorksheetFunction.VLookup(arr(j, 5), Sheet5.Range("a4:p20"), 列号, False)
  32.         End If
  33.     Next
  34.     [k5] = Timer - t
  35. End Sub</p><p>Public Function 列号()
  36. Dim rng1 As Range, rng2 As Range, nj%, bj%
  37.     nj = Sheet2.Range("b3"): bj = Sheet2.Range("c3")
  38.     Set rng1 = Sheet5.Range("b2:p2").Find(nj, , , , xlByRows, xlNext)
  39.     Set rng2 = Sheet5.Cells.Find(bj, rng1, , , xlByColumns, xlNext)
  40.     列号 = rng2.Column
  41. End Function
  42. </p>
复制代码




回复 支持 反对

使用道具 举报

发表于 2018-5-11 08:40:31 | 显示全部楼层
热身题1 写成事件  多表查询

  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim shtz As Worksheet, sht1 As Worksheet
  3.     Dim i As Long, j As Long, k As Long, l As Long
  4.     Dim rng As Range
  5.     k = 1
  6.     j = Worksheets.Count
  7.     Set sht1 = Worksheets("一班")
  8.     Set shtz = Worksheets("查询界面")



  9.     If Target.Address = [a2].Address Then
  10.        Set rng = shtz.Range("b2:d50")
  11.        rng.ClearContents
  12.         For l = 1 To j - 2
  13.             With Worksheets(l)
  14.                 For i = 2 To 11
  15.                     If .Cells(i, 2) = [a2].Value Then
  16.                         k = k + 1
  17.                         .Cells(i, 2).Offset(0, -1).Resize(1, 2).Copy shtz.Cells(k, 3)
  18.                         shtz.Cells(k, 2) = .Name

  19.                     End If
  20.                 Next
  21.             End With
  22.         Next
  23.      

  24.     End If

  25. End Sub
复制代码


模糊查找,用sub写了一个


  1. Sub 模糊匹配张()
  2.     Dim shtz As Worksheet, sht1 As Worksheet
  3.     Dim i As Long, j As Long, k As Long, l As Long
  4.     k = 1
  5.     j = Worksheets.Count
  6.     Set sht1 = Worksheets("一班")
  7.     Set shtz = Worksheets("查询界面")
  8.     For l = 1 To j - 2
  9.         With Worksheets(l)
  10.             For i = 2 To 11
  11.                 If .Cells(i, 1) Like shtz.Cells(2, 1) & "*" Then
  12.                     k = k + 1
  13.                     .Cells(i, 1).Offset(0, 0).Resize(1, 2).Copy shtz.Cells(k, 3)
  14.                     shtz.Cells(k, 2) = .Name
  15.                
  16.                 End If
  17.             Next
  18.             
  19.         End With
  20.     Next
  21. End Sub
复制代码



热身题2  高一下 课表

  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim sht1 As Worksheet, sht2 As Worksheet
  3.     Dim i As Long, j As Long, k As Long, l As Long, 行 As Long, 列 As Long, x As Long, y As Long
  4.     Dim 专业 As String, 班数 As Long
  5.    
  6.     Dim rng As Range
  7.     Set sht1 = Worksheets("教师名单")
  8.     Set sht2 = Worksheets("高一下学期2014.1.23")
  9.    
  10.     If Target.Address = [f3].Address Then
  11.         Set rng = sht2.Range("c10:be34")
  12.         rng.Interior.Color = xlNone
  13.         rng.Font.Color = 1
  14.         With sht1
  15.             For i = 3 To 72
  16.                 If [f3].Value = .Cells(i, 2) Then
  17.                     专业 = sht1.Cells(i, 3)
  18.                    ' 班数 = sht1.Cells(i, 2).End(xlToRight).Column
  19.                     For j = 4 To 12
  20.                         For x = 3 To 57
  21.                             For y = 10 To 33
  22.                         If .Cells(i, j) = sht2.Cells(8, x) And 专业 = sht2.Cells(y, x) Then
  23.                             列 = x
  24.                             行 = y
  25.                             sht2.Cells(行, 列).Interior.ColorIndex = 6
  26.                             sht2.Cells(行, 列).Font.ColorIndex = 3
  27.                         End If
  28.                                 Next
  29.                             Next
  30.                     Next
  31.                 End If
  32.             Next
  33.         End With
  34.    
  35.    
  36.     End If
  37.    
  38.    
  39. End Sub
复制代码


回复 支持 反对

使用道具 举报

发表于 2018-5-11 14:13:40 | 显示全部楼层
  1. Sub 手工检核()
  2. Dim rs%, i%, ar, n%, arr, brr(), num%, m%
  3. rs = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row - 1
  4.     For i = 1 To rs
  5.         arr = Sheet2.Range("d" & i + 1, "af" & i + 1)
  6.         For Each ar In arr
  7.             Select Case ar
  8.                 Case Is = "02"
  9.                     n = n + 1
  10.                     ReDim Preserve brr(1 To n)
  11.                     brr(n) = m
  12.                     m = 0
  13.                 Case Len(ar) > 2
  14.                     m = 0
  15.                 Case Is = "*"
  16.                     m = 0
  17.                 Case Is <> "*"
  18.                     m = m + 1
  19.             End Select
  20.         Next
  21.         If m <> 0 Then
  22.             ReDim Preserve brr(1 To n)
  23.             brr(n) = m
  24.         End If
  25.         maxn = WorksheetFunction.Max(brr)
  26.         If maxn > 7 Then Sheet2.Cells(i + 1, "ah") = maxn
  27.         m = 0
  28.         n = 1
  29.         maxn = 0
  30.         ReDim brr(1 To 1)
  31.     Next
  32. End Sub
复制代码
回复 支持 反对

使用道具 举报

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

本版积分规则

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