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

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

[复制链接]
发表于 2018-5-14 12:13:42 | 显示全部楼层 |阅读模式
VBA实战开发第五期-第三课作业贴
回复

使用道具 举报

发表于 2018-5-14 15:23:58 | 显示全部楼层
数组 留级的练习

  1. Sub 留级情况()
  2.     Dim arr()
  3.     Dim i As Long, k As Long
  4.     arr = Range("a1").CurrentRegion
  5.     ReDim brr(UBound(arr), 1 To 3)
  6.     brr(1, 1) = arr(1, 1)
  7.     brr(1, 2) = arr(1, 2)
  8.     brr(1, 3) = "结果"
  9.     k = 1
  10.     For i = 2 To UBound(arr)
  11.         If arr(i, 2) < 60 Then
  12.             k = k + 1
  13.             brr(k, 1) = arr(i, 1)
  14.             brr(k, 2) = arr(i, 2)
  15.             brr(k, 3) = "留级"
  16.         End If
  17.     Next
  18. Range("d5").Resize(UBound(brr), UBound(brr, 2)) = brr


  19. End Sub
复制代码



城市划分等级的练习

  1. Sub 城市()
  2.    
  3.     Dim arr(), brr(), crr()
  4.     Dim sht1 As Worksheet, sht2 As Worksheet
  5.     Dim i As Long, j As Long, k As Long, t
  6.     Set sht1 = Worksheets("sheet1")
  7.     Set sht2 = Worksheets("sheet2")
  8.     t = Timer
  9.     arr = sht2.Range("a1").CurrentRegion
  10.     brr = sht1.Range("a1").CurrentRegion
  11.     ReDim crr(1 To UBound(brr), 1 To 1)
  12.         For k = 1 To UBound(brr)
  13.         For i = 2 To UBound(arr)
  14.             For j = 1 To UBound(arr, 2)
  15.                 If arr(i, j) = brr(k, 2) Then
  16.                     crr(k, 1) = arr(1, j)
  17.                     
  18.                 End If
  19.             Next
  20.         Next
  21.     Next
  22.     sht1.Range("d1").Resize(UBound(crr), 1) = crr
  23.     MsgBox Timer - t
  24. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2018-5-14 15:25:23 | 显示全部楼层
数组 户口练习

  1. Sub 户主()
  2.     Dim arr(), brr(), crr()
  3.     Dim sht1 As Worksheet, sht2 As Worksheet
  4.     Dim i As Long, j As Long, k As Long, 行 As Long, 填 As Long, l As Long
  5.     Set sht1 = Worksheets("sheet1")
  6.     Set sht2 = Worksheets("sheet2")
  7.     arr = sht1.Range("b1").CurrentRegion
  8.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
  9.     k = 1
  10.     For i = 2 To UBound(arr)
  11.         If arr(i, 2) = sht2.Range("c2") Then
  12.             行 = i
  13.         End If
  14.         If 行 <> 0 Then Exit For
  15.     Next
  16.    
  17.     For i = 行 To UBound(arr)
  18.         If arr(i, 2) = arr(i + 1, 2) Then
  19.             sht2.Range("i4") = arr(i, 5)
  20.             k = k + 1
  21.         Else
  22.             brr = Range(sht1.Cells(i - k + 1, 3), sht1.Cells(i, 7))
  23.             Exit For
  24.         End If
  25.     Next
  26.     填 = 14
  27.     crr = Array("本人", "妻", "长子", "长女", "次子", "次女", "三子", "三女", "儿媳", "父亲", "母亲", "兄弟", "姐妹")
  28.     For l = 0 To UBound(crr)
  29.         For i = 1 To UBound(brr)
  30.    
  31.             If crr(l) = brr(i, 2) Then
  32.                 填 = 填 + 1
  33.                 sht2.Range("a" & 填) = brr(i, 1)
  34.                 sht2.Range("c" & 填) = brr(i, 2)
  35.                 sht2.Range("g" & 填) = brr(i, 3)
  36.             End If
  37.         
  38.         Next
  39.     Next

  40. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2018-5-16 19:58:17 | 显示全部楼层
  1. Sub 城市数据()
  2. Dim arr, brr, drr, i&, j&, p&
  3. t = Timer
  4. arr = Sheet1.Range("a1:c" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
  5. brr = WorksheetFunction.Transpose(Sheet2.Range("a1").CurrentRegion)
  6. ReDim drr(1 To UBound(arr))
  7.     For i = 1 To UBound(arr)
  8.         For p = 1 To UBound(brr)
  9.             For j = 1 To UBound(brr, 2)
  10.                 If brr(p, j) = "" Then Exit For
  11.                     If arr(i, 2) = brr(p, j) Then
  12.                     drr(i) = brr(p, 1)
  13.                     GoTo line1
  14.                 End If
  15.             Next
  16.         Next
  17. line1:
  18.     Next
  19.     Sheet1.Range("d1").Resize(UBound(drr)) = WorksheetFunction.Transpose(drr)
  20.     Sheet1.[e1] = Timer - t
  21. End Sub

复制代码


回复 支持 反对

使用道具 举报

发表于 2018-5-16 22:48:14 | 显示全部楼层
  1. Sub 户口信息查询()
  2. Dim arr, brr, crr(), counts%, i%, j%, rng As Range, n%
  3. Sheet2.Range("a15:i21").ClearContents
  4. counts = WorksheetFunction.CountIf(Sheet1.Range("b:b"), Sheet2.[c2].Value)
  5. Set rng = Sheet1.Range("b:b").Find(Sheet2.[c2].Value, , , , xlByColumns, xlNext)
  6. arr = rng.Resize(counts, 4)
  7. brr = [{"本人","妻","长子","长女","次子","次女","三子","三女","儿媳","孙子"}]
  8. ReDim crr(1 To counts, 1 To 9)
  9.     For i = 1 To UBound(brr)
  10.         For j = 1 To UBound(arr)
  11.            If arr(j, 3) = brr(i) Then
  12.                 n = n + 1
  13.                 crr(n, 1) = arr(j, 1)
  14.                 crr(n, 3) = arr(j, 3)
  15.                 crr(n, 7) = arr(j, 4)
  16.                 Exit For
  17.            End If
  18.         Next j
  19.         If n = counts Then Exit For
  20.     Next i
  21.     Sheet2.Range("a15").Resize(counts, 9) = crr
  22. End Sub
复制代码


回复 支持 反对

使用道具 举报

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

本版积分规则

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