设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 培训班 › Excel VBA字典班 › 【VBA字典数组201301班】B组-第一讲作业上交处
12下一页
返回列表 发新帖
查看: 6122|回复: 16

[通知] 【VBA字典数组201301班】B组-第一讲作业上交处

[复制链接]
发表于 2013-11-2 16:00 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 从从容容 于 2013-11-9 20:30 编辑

本贴为B组作业上交专用,其他组员勿入~~~
对于本次作业添加一个小要求,5道题中,必需有一题解法中使用 ReDim Preserve  
1、作业提交请用上传附件或直接跟帖方式，；
2、附件文件名或帖子标题按要求格式命名：组号-论坛ID,
       如：【VBA字典数组201301班】-B03-ls；
3、作业截止时间：2013-11-6 18:00；
上交, 命名

相关帖子

excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

zmnyu
发表于 2013-11-2 16:09 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 zmnyu 于 2013-11-2 23:25 编辑


重新上交作业了，哈哈



VBA字典数组201301班】B03-zmnyu-1.rar (66.04 KB, 下载次数: 24)

评分

参与人数 2 +20 金币 +20 收起 理由
寂寞深水鱼 + 10 + 10 补分
从从容容 + 10 + 10 很好，第四题还用了两种方法。

查看全部评分

回复

使用道具 举报

发表于 2013-11-2 20:49 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
【VBA字典数组201301班】-B07-shanxiren.rar (58.12 KB, 下载次数: 17)

评分

参与人数 2 +18 金币 +18 收起 理由
寂寞深水鱼 + 9 + 9 补分
从从容容 + 9 + 9 第二题，做得不够好，

查看全部评分

回复

使用道具 举报

ls
发表于 2013-11-2 22:29 | 显示全部楼层
本帖最后由 ls 于 2013-11-4 14:44 编辑

游客，如果您要查看本帖隐藏内容请回复



评分

参与人数 2 +18 金币 +20 收起 理由
寂寞深水鱼 + 9 + 10 补分
从从容容 + 9 + 10 不错，但第二题的代码不是最好。可以参阅别.

查看全部评分

回复

使用道具 举报

wp8680
发表于 2013-11-2 22:44 | 显示全部楼层
【VBA字典数组201301班】-B09-wp8680
  1. Option Explicit

  3. Sub 作业一()
  4.     Dim arr, m%, n%, ir%, brr()
  5.     ir = Range("a" & Cells.Rows.Count).End(xlUp).Row
  6.     arr = Range("a1:a" & ir)
  7.     ReDim brr(1 To UBound(arr), 1 To 3)
  8.     For m = 1 To UBound(arr)
  9.         For n = 1 To 3
  10.             brr(m, n) = Split(arr(m, 1), "*")(n - 1)
  11.         Next n
  12.     Next m
  13.     With Range("b1").Resize(UBound(brr), UBound(brr, 2))
  14.     .NumberFormatLocal = "@"
  15.     .HorizontalAlignment = xlRight
  16.     .Value = brr
  17.     End With
  18. End Sub

  20. Sub 作业二()
  21.     Dim arr, brr(1 To 5, 1 To 4), m%, n%, x%, y%, a%
  22.     arr = Range("b2:f12")
  23.     For m = 1 To UBound(arr, 1)
  24.         For n = 1 To UBound(arr, 2)
  25.             x = (Int(arr(m, n) / 100) Mod 5) + 1
  26.             y = Int(Int(arr(m, n) / 100) / 5) * 2 + 2
  27.             brr(x, y) = brr(x, y) + 1
  28.         Next n
  29.     Next m
  30.     For a = 1 To 5
  31.     brr(a, 1) = "<" & a * 100
  32.     brr(a, 3) = "<" & (a + 5) * 100
  33.     Next a
  34.   Range("h4").Resize(5, 4) = brr
  35.    Range("h3").Resize(1, 4) = Array("条件", "个数", "条件", "个数")
  36. End Sub

  38. Sub 作业三()
  39.     Dim arr, m%, n%, brr()
  40.     arr = Range("b3:f13")
  41.     ReDim brr(1 To UBound(arr), 0 To 4)
  42.     For m = 1 To UBound(arr, 1)
  43.         brr(m, 0) = m
  44.         brr(m, 1) = 0
  45.         brr(m, 2) = 9E+307
  46.         For n = 1 To UBound(arr, 2)
  47.             If arr(m, n) > brr(m, 1) Then brr(m, 1) = arr(m, n)
  48.             If arr(m, n) < brr(m, 2) Then brr(m, 2) = arr(m, n)
  49.             brr(m, 4) = brr(m, 4) + arr(m, n)
  50.         Next n
  51.         brr(m, 3) = brr(m, 4) / 5
  52.     Next m
  53.     Range("i3").Resize(UBound(brr), 4) = brr
  54.     Range("i2:m2") = Array("序号", "最大数", "最小数", "平均值", "和")
  55. End Sub

  57. Sub 作业四()
  58.     Dim arr, st, m%, n%, x, brr()
  59.     arr = Range("c13:g27")
  60.     For m = 1 To UBound(arr, 1)
  61.         For n = 1 To UBound(arr, 2)
  62.             If InStr(1, st, arr(m, n), 1) = 0 Then
  63.                 x = x + 1
  64.                 st = st & arr(m, n)
  65.                 ReDim Preserve brr(1 To x)
  66.                 brr(x) = arr(m, n)
  67.             End If
  68.         Next n
  69.     Next m
  70.     Range("c43").Resize(UBound(brr), 1) = Application.WorksheetFunction.Transpose(brr)
  71. End Sub

  73. Sub 作业五()
  74. Dim arr, st, m%, n%, x, brr()
  75.     arr = Range("c9:g23")
  76.     For m = 1 To UBound(arr, 1)
  77.         For n = 1 To UBound(arr, 2)
  78.             If InStr(st, arr(m, n)) = 0 Then
  79.                 x = x + 1
  80.                 st = st & "@" & arr(m, n)
  81.                 ReDim Preserve brr(1 To x)
  82.                 brr(x) = arr(m, n)
  83.             End If
  84.         Next n
  85.     Next m
  86.     Range("l8").Resize(UBound(brr), 1) = Application.WorksheetFunction.Transpose(brr)
  87. End Sub
复制代码

评分

参与人数 2 +20 金币 +20 收起 理由
寂寞深水鱼 + 10 + 10 补分
从从容容 + 10 + 10 赞一个!，很好！

查看全部评分

回复

使用道具 举报

发表于 2013-11-3 17:04 | 显示全部楼层
本帖最后由 从从容容 于 2013-11-6 21:06 编辑

。
Option Explicit
Sub 作业一()
    Dim x As Long
    Dim k As Integer
    Dim arr, arr1, arr2(1 To 10000, 1 To 3)
    With Sheet1
        .Range("b1:d1000") = ""
        arr = .Range("a1:a17")
        For x = 1 To UBound(arr, 1)
            arr1 = Split(arr(x, 1), "*")
            k = k + 1
            arr2(k, 1) = arr1(0)
            arr2(k, 2) = arr1(1)
            arr2(k, 3) = arr1(2)
        Next x
        .Range("B1").Resize(k, 3).NumberFormatLocal = "@"
        .Range("b1").Resize(k, 3) = arr2
    End With
End Sub

Sub 作业二()
    Dim i, j, x, m
    Dim arr
    Dim brr(1 To 5, 1 To 4)
    With Sheet2
    arr = .Range("b2:f12")
    For i = 1 To UBound(arr, 1)
        For j = 1 To UBound(arr, 2)
            m = arr(i, j)
            x = Int(arr(i, j) / 100) + 1
            If x < 6 Then
                brr(x, 2) = brr(x, 2) + 1
            Else
                brr(x - 5, 4) = brr(x - 5, 4) + 1
            End If

        Next
    Next
    For i = 1 To 5
        brr(i, 1) = "<" & i * 100
        brr(i, 3) = "<" & (i + 5) * 100
    Next i
   .Range("h4").Resize(5, 4) = brr
    .Range("h3").Resize(1, 4) = Array("条件", "个数", "条件", "个数")
End With
End Sub

Sub 作业三()
    Dim arr(), brr()
    Dim x, x1, y, 最小数, 最大数, 求和
    arr = Range("B3:F13")
    ReDim Preserve brr(1 To 12, 1 To 5)
    For x = 1 To UBound(arr, 1)
        最大数 = 0
        最小数 = 1001
        求和 = 0
        For y = 1 To UBound(arr, 2)

            If arr(x, y) >= 最大数 Then 最大数 = arr(x, y)
            If arr(x, y) <= 最小数 Then 最小数 = arr(x, y)
            求和 = 求和 + arr(x, y)
        Next y
        brr(x, 1) = x
        brr(x, 2) = 最大数
        brr(x, 3) = 最小数
        brr(x, 4) = 求和 / 5
        brr(x, 5) = 求和
    Next x
    Range("i3").Resize(UBound(brr), 5) = brr
    Range("i2:m2") = Array("序号", "最大数", "最小数", "平均值", "和")
End Sub

Sub 第四题()
    Dim cn As New Collection, i&, a
    On Error Resume Next
    For Each a In Range("C13:G27")
        cn.Add CStr(a), a
    Next
    For i = 0 To cn.Count
        Cells(i + 42, 3) = cn.Item(i)
    Next
End Sub
Sub 作业五()
Sheet7.Range("l8:l100") = ""
    Dim i, j, x, k, y, n
    Dim arr, arr1(1 To 1000)
    arr = Sheet7.Range("c9:g23")
    For i = 1 To UBound(arr, 1)
        For n = 1 To UBound(arr, 2)
            For j = 1 To UBound(arr1)
                x = arr(i, n): y = arr1(j) '辅助查看
                If arr(i, n) = arr1(j) Then
                    GoTo 100
                End If
            Next j
            k = k + 1
            arr1(k) = arr(i, n)
100
        Next n
    Next i
    Sheet7.Range("l8").Resize(k) = Application.Transpose(arr1)
End Sub

点评

从从容容
ReDim Preserve brr(1 To 12, 1 To 5) 这句没有真正用preserve.  发表于 2013-11-6 21:09
从从容容
第四题 用Collection，很不错，后面如果能用到数组就更好了  发表于 2013-11-6 21:04

评分

参与人数 2 +18 金币 +20 收起 理由
寂寞深水鱼 + 9 + 10 补分
从从容容 + 9 + 10 赞一个!

查看全部评分

回复

使用道具 举报

发表于 2013-11-5 09:11 | 显示全部楼层
  1. Sub 作业一()
  2. Dim arr, brr
  3. Dim rg As Range
  4. Dim i As Long
  5. Dim r As Long
  6. r = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
  7. ReDim arr(1 To r, 1 To 3)
  8. For Each rg In Sheet1.Range("a1:a" & r)
  9. brr = Split(rg, "*")
  10. i = i + 1
  11. arr(i, 1) = brr(0)
  12. arr(i, 2) = brr(1)
  13. arr(i, 3) = brr(2)
  14. Next rg
  15. With Sheet1
  16. .Range("c1").Resize(UBound(arr), 3).Clear
  17. .Range("c1").Resize(UBound(arr), 3).NumberFormatLocal = "@"
  18. .Range("c1").Resize(UBound(arr), 3) = arr
  19. End With
  20. End Sub

  22. Sub 作业二()
  23. Dim arr, brr, ary
  24. Dim i As Long, j As Long
  25. arr = Sheet2.Range("b2:f12")
  26. ary = Array("条件", "个数", "条件", "个数")
  27. ReDim brr(1 To 6, 1 To 4)
  28. For i = 1 To UBound(brr, 2)
  29. brr(1, i) = ary(i - 1)
  30. Next i
  31. For i = 1 To UBound(arr)
  32. For j = 1 To UBound(arr, 2)
  33. Select Case arr(i, j)
  34. Case Is < 100
  35. brr(2, 1) = "<100"
  36. brr(2, 2) = brr(2, 2) + 1
  37. Case Is < 200
  38. brr(3, 1) = "<200"
  39. brr(3, 2) = brr(3, 2) + 1
  40. Case Is < 300
  41. brr(4, 1) = "<300"
  42. brr(4, 2) = brr(4, 2) + 1
  43. Case Is < 400
  44. brr(5, 1) = "<400"
  45. brr(5, 2) = brr(5, 2) + 1
  46. Case Is < 500
  47. brr(6, 1) = "<500"
  48. brr(6, 2) = brr(6, 2) + 1
  49. Case Is < 600
  50. brr(2, 3) = "<600"
  51. brr(2, 4) = brr(2, 4) + 1
  52. Case Is < 700
  53. brr(3, 3) = "<700"
  54. brr(3, 4) = brr(3, 4) + 1
  55. Case Is < 800
  56. brr(4, 3) = "<800"
  57. brr(4, 4) = brr(4, 4) + 1
  58. Case Is < 900
  59. brr(5, 3) = "<900"
  60. brr(5, 4) = brr(5, 4) + 1
  61. Case Is < 1000
  62. brr(6, 3) = "<1000"
  63. brr(6, 4) = brr(6, 4) + 1
  64. End Select
  65. Next j
  66. Next i
  67. With Sheet2
  68. .Range("h3:k8").ClearContents
  69. .Range("h3").Resize(UBound(brr), 4) = brr
  70. End With
  71. End Sub

  73. Sub 作业三()
  74. Dim arr, brr, bt
  75. Dim i As Integer, j As Integer
  76. bt = Array("序号", "最大数", "最小数", "平均值", "和")
  77. With Sheet3
  78. .Range("i2:m13").ClearContents
  79. arr = .Range("a2:f13")
  80. brr = .Range("i2:m13")
  81. For i = 1 To UBound(brr, 2)
  82. brr(1, i) = bt(i - 1)
  83. Next i
  84. For i = 2 To UBound(arr)
  85. brr(i, 3) = arr(i, 2)
  86. For j = 2 To UBound(arr, 2)
  87. If arr(i, j) > brr(i, 2) Then brr(i, 2) = arr(i, j)
  88. If arr(i, j) < brr(i, 3) Then brr(i, 3) = arr(i, j)
  89. brr(i, 5) = brr(i, 5) + arr(i, j)
  90. If j <= UBound(arr, 2) - 1 Then
  91. brr(i, 4) = brr(i, 4) + arr(i, j)
  92. Else
  93. brr(i, 4) = (brr(i, 4) + arr(i, j)) / (j - 1)
  94. End If
  95. Next j
  96. brr(i, 1) = i - 1

  98. Next i
  99. .Range("i2").Resize(UBound(brr), UBound(brr, 2)) = brr
  100. End With
  101. End Sub

  103. Sub 作业四()
  104.     Dim i As Integer, j As Integer, m As Integer
  105.     m = 12
  106.     With Sheets(4)
  107.         .Range("i13:i10000") = ""
  108.         .Range("c43:c10000") = ""
  109.         For j = 3 To 7
  110.             For i = 13 To 27
  111.                 m = m + 1
  112.                 .Cells(m, 9) = UCase(.Cells(i, j).Value)
  113.             Next
  114.         Next
  115.         .Range("I13:I" & m).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range( _
  116.                                                                     "C43"), Unique:=True
  117.         .Range("I13:I" & m).ClearContents

  119.     End With
  120. End Sub

  122. Sub 作业五()
  123. Dim arr, brr, crr
  124. Dim i As Integer, j As Integer, m As Integer
  125. With Sheets(5)
  126. .Range("l8:l30").ClearContents
  127. arr = .Range("c9:g23")
  128. brr = .Range("l8:l30")
  129. For i = 1 To UBound(arr, 2)
  130. For j = 1 To UBound(arr)
  131. brr(arr(j, i), 1) = arr(j, i)
  132. Next j
  133. Next i
  134. ReDim crr(1 To UBound(brr), 1 To 1)
  135. For i = 1 To UBound(brr)
  136. If brr(i, 1) <> "" Then
  137. m = m + 1
  138. crr(m, 1) = brr(i, 1)
  139. End If
  140. Next i
  141. .Range("l8").Resize(UBound(crr), 1) = crr
  142. End With
  143. End Sub
复制代码

点评

从从容容
第二题代码不够简洁。第五题前半段写得很不错，后半段有点多余了。 还有没有用到 preserve .  发表于 2013-11-6 20:06

评分

参与人数 2 +16 金币 +18 收起 理由
寂寞深水鱼 + 8 + 9 补分
从从容容 + 8 + 9 赞一个!

查看全部评分

回复

使用道具 举报

发表于 2013-11-5 11:26 | 显示全部楼层
B10 临时户口交作业
  1. Sub 作业一()
  2.     Range("b1:c17").ClearContents
  3.     Dim arr, arr1
  4.     Dim x As Long, y As Long
  5.     arr = Range("a1:a17").Value
  6.     For x = 1 To UBound(arr)
  7.         arr1 = VBA.Split(arr(x, 1), "*")
  8.         Range("b" & x).Resize(1, UBound(arr1) + 1).Value = arr1
  9.     Next
  10. End Sub
复制代码

点评

从从容容
作业一做的不错，但没有看到后面的作业。  发表于 2013-11-7 12:01

评分

参与人数 2 +4 金币 +4 收起 理由
寂寞深水鱼 + 2 + 2 补分
从从容容 + 2 + 2 赞一个!

查看全部评分

回复

使用道具 举报

发表于 2013-11-5 12:35 | 显示全部楼层
B06:幽月儿

【VBA字典数组201301班】-B06-幽月儿.rar

38.89 KB, 下载次数: 2

点评

从从容容
作业2 没有使用数组，也不完整；作业4做得不错。  发表于 2013-11-7 11:43

评分

参与人数 1 +8 金币 +8 收起 理由
从从容容 + 8 + 8 赞一个!

查看全部评分

回复

使用道具 举报

发表于 2013-11-5 16:46 | 显示全部楼层
只会第一题其他不会
还要向老师多多学习

【VBA字典数组201301班】-B02-望天打卦.rar

59.6 KB, 下载次数: 3

点评

从从容容
作业1 前面做得不错，但后面数组可以一次性写入单元格区域。后面几题没能完成。希望继续努力。  发表于 2013-11-7 11:48

评分

参与人数 2 +4 金币 +4 收起 理由
寂寞深水鱼 + 2 + 2 补分
从从容容 + 2 + 2 加油！

查看全部评分

回复

使用道具 举报

下一页 »
12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-24 00:59 , Processed in 0.488906 second(s), 22 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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