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

Excel精英培训网

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

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

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

本贴为【VBA字典数组201301班】B组 第四讲作业 上交专用，其它学员勿入
作业要求：
1.要求使用字典完成
2.所有的代码均写在按钮指定的过程中
3.要求代码缩进
4.要求有注释（关键代码处）
5.要求强制声明

备注:只需要将代码贴出来即可,大家看清楚了
  1. Sub 作业一()
  2.     Dim dic As Object
  3.     Set dic = CreateObject("scripting.dictionary")
  4.     Dim arr, brr(1 To 1000, 1 To 12)
  5.     Dim sh As Worksheet
  6.     Dim x%, y%, n%, k%, t#
  7.     arr = Sheets("源数据一").Range("A2:L" & Sheets("源数据一").Cells(Rows.Count, 1).End(xlUp).Row)
  8.     For x = 1 To UBound(arr)
  9.         m = arr(x, 1) & vbTab & arr(x, 2) & vbTab & arr(x, 3) & vbTab & arr(x, 4) & vbTab & arr(x, 5) & vbTab & arr(x, 6) & vbTab & arr(x, 7) & vbTab & arr(x, 8)
  10.         If dic.Exists(m) Then
  11.             k = dic(m)
  12.             brr(k, 9) = brr(k, 9) & " " & arr(x, 9)
  13.             brr(k, 10) = brr(k, 10) + arr(x, 10)
  14.         Else
  15.             n = n + 1
  16.             dic(m) = n
  17.             For y = 1 To 12
  18.                 brr(n, y) = arr(x, y)
  19.             Next
  20.             If arr(x, 8) = "连锡" Then brr(n, 12) = ""
  21.         End If
  22.     Next x
  23.     Set sh = Sheets.Add
  24.     sh.[A2].Resize(dic.Count, 12) = brr
  25.     Sheets("源数据一").Range("A1").Resize(, 12).Copy sh.[a1].Resize(, 12)
  26.     sh.Name = "第一题答案-" & Format(Time, "hhmm")
  27. End Sub
  28. Sub 作业二()
  29.     Dim i As Long
  30.     Dim m As String
  31.     Dim n As String
  32.     Dim k As Integer
  33.     Dim j As Long
  34.     Dim arr(), arr1(), crr(1 To 10000, 1 To 6)
  35.     Dim d As New Dictionary
  36.     With Sheet6
  37.         arr = .Range("a2:f" & .Range("a65536").End(xlUp).Row)
  38.         arr1 = .Range("h2:m" & .Range("H65536").End(xlUp).Row)
  39.         For i = 1 To UBound(arr)
  40.             m = arr(i, 1) & vbTab & arr(i, 2) & vbTab & arr(i, 3) & vbTab & arr(i, 4) & vbTab & arr(i, 5) & vbTab & arr(i, 6)
  41.             d(m) = ""
  42.         Next
  43.         For i = 1 To UBound(arr1, 1)
  44.             n = arr1(i, 1) & vbTab & arr1(i, 2) & vbTab & arr1(i, 3) & vbTab & arr1(i, 4) & vbTab & arr1(i, 5) & vbTab & arr1(i, 6)
  45.             If d.Exists(n) = True Then
  46.                 k = k + 1
  47.                 For j = 1 To UBound(arr1, 2)
  48.                     crr(k, j) = arr1(i, j)
  49.                 Next
  50.             End If
  51.         Next
  52.         .Range("o5").Resize(k, 6) = crr
  53.     End With
  54. End Sub
  55. Sub 作业三()
  56.     Dim i, j
  57.     Dim arr, arr1(1 To 10000, 1 To 3)
  58.     Dim d As New Dictionary
  59.     With Sheet7
  60.         arr = .Range("a2:c" & .Range("a65536").End(xlUp).Row)
  61.         For i = 1 To UBound(arr)
  62.             If arr(i, 3) <> "" And arr(i, 1) = "湖北" Then
  63.                 If d.Exists(arr(i, 1) & arr(i, 2) & arr(i, 3)) = False Then
  64.                     d(arr(i, 1) & arr(i, 2) & arr(i, 3)) = d.Count + 1
  65.                     For j = 1 To UBound(arr, 2)
  66.                         arr1(d.Count, j) = arr(i, j)
  67.                     Next j
  68.                 End If
  69.             End If
  70.         Next i
  71.         .Range("e2").Resize(d.Count, 3) = arr1
  72.     End With
  73. End Sub
复制代码
上交

相关帖子

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

使用道具 举报

发表于 2013-11-23 21:36 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 雨后彩霞 于 2013-11-24 21:13 编辑

Sub 作业一()
Dim dic As New Dictionary
Dim arr, brr
Dim x%, y%, n%
arr = Sheets("源数据一").Range("A2:L" & Sheets("源数据一").Cells(Rows.Count, 1).End(xlUp).Row)
For x = 1 To UBound(arr)
    m = arr(x, 1) & vbTab & arr(x, 2) & vbTab & arr(x, 3) & vbTab & arr(x, 4) & vbTab & arr(x, 5) & vbTab & arr(x, 6) & vbTab & arr(x, 7) & vbTab & arr(x, 8)    'm=arr(x,1) & Tab键 & arr(x,2) & Tab键 & arr(x,3) & Tab键 & arr(x,4) & Tab键 & arr(x,5) & Tab键 & arr(x,6) & Tab键 & arr(x,7) & Tab键 & arr(x,8)
    If Not dic.Exists(m) Then    '如果  非  dic的存在m) 则执行
        n = n + 1
        
        dic.Add m, n    ' dic的添加 m,n
        
        Debug.Print m & "  " & dic(m)    ' 调试方式的输出显示 m & "" & dic(m)
        
    End If
   
    Next x
ReDim brr(1 To dic.Count, 1 To 12)    '重定义变量brr(1到 dic的计数值,1到12)
For i = 1 To UBound(arr)
    m = arr(i, 1) & vbTab & arr(i, 2) & vbTab & arr(i, 3) & vbTab & arr(i, 4) & vbTab & arr(i, 5) & vbTab & arr(i, 6) & vbTab & arr(i, 7) & vbTab & arr(i, 8)
   
    If dic.Exists(m) Then    '如果  dic的存在m) 则执行
   
        For y = 1 To 8    '设定变量范围为y=1到8
        
            brr(dic(m), y) = Split(m, vbTab)(y - 1)    'brr(dic(m),y)=<分割字符串>(m,Tab键)(y-1)
            
        Next
        
        If Len(brr(dic(m), 9)) = 0 Then: brr(dic(m), 9) = arr(dic(m), 9): Else: brr(dic(m), 9) = brr(dic(m), 9) & " " & arr(i, 9)    '如果 <字符串长度值>(brr(dic(m),9))=0 则执行 :brr(dic(m),9)=arr(dic(m),9):另外:brr(dic(m),9)=brr(dic(m),9) & "" & arr(i,9)
            
            For y = 10 To 12
            
                brr(dic(m), y) = brr(dic(m), y) + arr(i, y)
               
            Next
            
        End If
        
    Next
   
    Sheets.Add.Name = "Sheet1"   ' 添加 的名称="Sheet1"
   
    Sheets("Sheet1").Range("a1:l1") = Array("生产日期", "编号", "周期", "月份", "产品型号", "生产线", "班组", "不良类型", "不良位置", "不良数量", "备注", "产量")
   
End Sub

Sub 作业二()
Dim i As Long    '定义变量 i 为 长整型值
Dim m As String    '定义变量 m 为 字符串
Dim n As String    '定义变量 n 为 字符串
Dim k As Integer    '定义变量 k 为 整型值
Dim j As Long    '定义变量 j 为 长整型值
Dim arr(), arr1(), crr(1 To 10000, 1 To 6)
Dim d As New Dictionary    '定义变量 d 为  新的 字典
With Sheet6    '工作于Sheet6
    arr = .Range("a2:f" & .Range("a65536").End(xlUp).Row)
    arr1 = .Range("h2:m" & .Range("H65536").End(xlUp).Row)
   
    For i = 1 To UBound(arr)
        m = arr(i, 1) & vbTab & arr(i, 2) & vbTab & arr(i, 3) & vbTab & arr(i, 4) & vbTab & arr(i, 5) & vbTab & arr(i, 6) '将各列连接起来
        d(m) = ""    'd(m)=空值
    Next
     For i = 1 To UBound(arr1, 1)
     n = arr1(i, 1) & vbTab & arr1(i, 2) & vbTab & arr1(i, 3) & vbTab & arr1(i, 4) & vbTab & arr1(i, 5) & vbTab & arr1(i, 6) '将各列连接起来
        If d.Exists(n) = True Then    '如果  d的存在n)=True 则执行
            k = k + 1
             For j = 1 To UBound(arr1, 2)
            crr(k, j) = arr1(i, j)    'crr(k,j)=arr1(i,j)
            Next
            
        End If
        
    Next
   
    .Range("o5").Resize(k, 6) = crr
   
End Sub
Sub 作业三()
Dim i, j
Dim arr, arr1(1 To 10000, 1 To 3)
Dim d As New Dictionary    '定义变量 d 为  新的 字典
With Sheet7    '工作于Sheet7
    arr = .Range("a2:c" & .Range("a65536").End(xlUp).Row)
   
    For i = 1 To UBound(arr)    '设定变量范围为i=1到<数组上限>(arr)
   
        If arr(i, 3) <> "" And arr(i, 1) = "湖北" Then    '如果 arr(i,3) 不等于 空值 并且 arr(i,1)="湖北" 则执行
        
            If d.Exists(arr(i, 1) & arr(i, 2) & arr(i, 3)) = False Then    '如果  d的存在arr(i,1) & arr(i,2) & arr(i,3))=False 则执行
               
                 d(arr(i, 1) & arr(i, 2) & arr(i, 3)) = d.Count + 1    'd(arr(i,1) & arr(i,2) & arr(i,3))= d的计数值+1
               
                For j = 1 To UBound(arr, 2)    '设定变量范围为j=1到<数组上限>(arr,2)
                    
                    arr1(d.Count, j) = arr(i, j)    'arr1( d的计数值,j)=arr(i,j)
               
                Next j
            
            End If
        
        End If
   
    Next i
    .Range("e2").Resize(d.Count, 3) = arr1    '<With对象>的<单元格>区域("e2" )的<重调大小>( d的计数值,3)=arr1
End With    'With语句结束
End Sub

点评

从从容容
作业一,sheets1 怎么内容;作业二, 没有 end with结束,  发表于 2013-11-28 10:22

评分

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

查看全部评分

回复

使用道具 举报

wp8680
发表于 2013-11-24 17:41 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
B09:wp8680
  1. Option Explicit

  3. Sub 作业一()
  4.     Dim d, arr, k%, m%, brr(), st$, crr, x
  5.     Set d = CreateObject("scripting.dictionary") '字典对像
  6.     arr = Sheets("源数据一").UsedRange.Value     '提取源数据
  7.     ReDim brr(1 To UBound(arr), 1 To 4)          '设置一个空数组用以存放结果
  8.     For k = 2 To UBound(arr)
  9.         st = Join(Application.Index(arr, k, 0), "|")  '经实践用index和Join结合处理时间慢于逐个直接连接
  10.         st = Left(st, InStr(st, "焊") + InStr(st, "锡")) '设置分类汇总的条件字段
  11.         If d.exists(st) Then                     '判断是否字典中已经存在，如存在则提该key的item属性（brr行位置）
  12.             brr(d.Item(st), 1) = brr(d.Item(st), 1) & " " & arr(k, 9)
  13.             brr(d.Item(st), 2) = brr(d.Item(st), 2) + arr(k, 10)
  14.             brr(d.Item(st), 3) = arr(k, 11)
  15.         Else                                     '如不存在则增加字典key,并按序添加该key的注释item
  16.             m = m + 1
  17.             d(st) = m
  18.             brr(m, 1) = arr(k, 9)
  19.             brr(m, 2) = arr(k, 10)
  20.             brr(m, 3) = arr(k, 11)
  21.             If arr(k, 8) = "假焊" Then brr(m, 4) = arr(k, 12)
  22.         End If
  23.     Next k
  24.     Worksheets.Add after:=ActiveSheet         '新建工作表存放结果
  25.     With ActiveSheet
  26.         .Name = "第一题答案-" & Format(Now, "hhmm")
  27.         crr = d.keys                          '把字典的所有Key存到crr数组中
  28.         For k = 1 To d.Count                  '依次对字典的Key(crr中数据)进行分列,并写入工作表
  29.             .Cells(k + 1, 1).Resize(1, 8) = Split(crr(k - 1), "|")
  30.         Next k
  31.         .Cells(2, 9).Resize(m, 4) = brr       '把结果写入工作表
  32.         .Range("a1:l1") = Sheets("源数据一").Range("a1:l1").Value '写标题行
  33.         .Columns("A:L").EntireColumn.AutoFit   '自动调整列宽
  34.     End With
  35. End Sub
  36. Sub 作业二()
  37.     Dim arr, brr, d1, d2, crr(), k&, m%, a%
  38.     arr = Sheets("作业二").Range("a2:f40000")
  39.     brr = Sheets("作业二").Range("h2:m40000")
  40.     Set d1 = CreateObject("scripting.dictionary")    '字典对像
  41.     For k = 1 To 39999 '循环arr数据，并建立字典Keys
  42.         d1(arr(k, 1) & "|" & arr(k, 2) & "|" & arr(k, 3) & "|" & arr(k, 4) & "|" & arr(k, 5) & "|" & arr(k, 6)) = ""
  43.     Next k
  44.     For k = 1 To UBound(brr) '循环数组brr，并查询每横向维中的字符在字典中是否存在，如果存在则按序提到crr中
  45.         If d1.exists(brr(k, 1) & "|" & brr(k, 2) & "|" & brr(k, 3) & "|" & brr(k, 4) & "|" & brr(k, 5) & "|" & brr(k, 6)) Then
  46.             m = m + 1
  47.             ReDim Preserve crr(1 To 6, 1 To m)
  48.             For a = 1 To 6
  49.                 crr(a, m) = brr(k, a)
  50.             Next a
  51.         End If
  52.     Next k
  53.     Range("o2").Resize(m, 6) = Application.WorksheetFunction.Transpose(crr)
  54. End Sub
  55. Sub 作业三()
  56.     Dim arr, k%, d, brr, crr()
  57.     arr = Sheets("作业三").Range("a2:c25")
  58.     Set d = CreateObject("scripting.dictionary")   '字典对像
  59.     For k = 1 To UBound(arr)
  60.         If arr(k, 1) = "湖北" Then d(arr(k, 1) & "|" & arr(k, 2) & "|" & arr(k, 3)) = ""
  61.     Next k
  62.     brr = d.keys
  63.     ReDim crr(1 To d.Count, 1 To 3)
  64.     For k = 1 To d.Count
  65.         crr(k, 1) = Split(brr(k - 1), "|")(0)
  66.         crr(k, 2) = Split(brr(k - 1), "|")(1)
  67.         crr(k, 3) = Split(brr(k - 1), "|")(2)
  68.     Next k
  69.     Range("e2").Resize(UBound(crr), 3) = crr
  70. End Sub
复制代码

点评

从从容容
很不错,还用了动态数组.只是作业三的注释太少了.代码比较简洁.  发表于 2013-11-28 10:31

评分

参与人数 1 +6 金币 +20 收起 理由
从从容容 + 6 + 20 很给力!

查看全部评分

回复

使用道具 举报

发表于 2013-11-25 17:45 | 显示全部楼层
B08:缔造者
  1. Option Explicit

  3. Sub 作业一()
  4.     Dim dac As Object
  5.     Dim arr, t
  6.     Dim jg(1 To 10000, 1 To 15)    '声明一个比源数据区域较大一点的数组
  7.     Dim str As String, shtname As String
  8.     Dim i As Long, j As Long, h As Long
  9.     Dim sht As Worksheet
  10.     t = Timer    '记录程序开始运行的时间
  11.     Set dac = CreateObject("scripting.dictionary")    '创建字典对象
  12.     With Sheets("源数据一")    '执行with语句
  13.         arr = .Range("a1").CurrentRegion    '将单元格A1所在的区域赋值给变量arr
  14.         For i = 2 To UBound(arr)    '遍历数组arr
  15.             str = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4) _
  16.                 & "," & arr(i, 5) & "," & arr(i, 6) & "," & arr(i, 7) & "," & arr(i, 8)    '用逗号建立一个字符串并赋值给变量str
  17.             If dac.exists(str) Then    '判断字典中是否存在字符串str
  18.                 h = dac(str)    '记录字符串str所在的行数
  19.                 jg(h, 9) = jg(h, 9) & " " & arr(i, 9)    '给数组jg赋值
  20.                 jg(h, 10) = jg(h, 10) + arr(i, 10)    '给数组jg赋值
  21.             Else
  22.                 j = j + 1    '计数器
  23.                 dac(str) = j    '将字符串装入字典，其对应的项为变量j
  24.                 jg(j, 1) = arr(i, 1)    '给数组jg赋值
  25.                 jg(j, 2) = arr(i, 2)    '给数组jg赋值
  26.                 jg(j, 3) = arr(i, 3)    '给数组jg赋值
  27.                 jg(j, 4) = arr(i, 4)    '给数组jg赋值
  28.                 jg(j, 5) = arr(i, 5)    '给数组jg赋值
  29.                 jg(j, 6) = arr(i, 6)    '给数组jg赋值
  30.                 jg(j, 7) = arr(i, 7)    '给数组jg赋值
  31.                 jg(j, 8) = arr(i, 8)    '给数组jg赋值
  32.                 jg(j, 9) = arr(i, 9)    '给数组jg赋值
  33.                 jg(j, 10) = arr(i, 10)    '给数组jg赋值
  34.                 jg(j, 11) = arr(i, 11)    '给数组jg赋值
  35.                 jg(j, 12) = IIf(arr(i, 8) = "连锡", "", arr(i, 12))    '判断数组arr的第8列是否为“连锡”字符，将其结果赋值给数组jg
  36.             End If    '结束判断
  37.         Next i    '继续下一个
  38.     End With    '结束with语句
  39.     Set dac = Nothing    '释放字典内存
  40.     Application.ScreenUpdating = False    '关闭屏幕刷新
  41.     For Each sht In Worksheets    '遍历工作表
  42.         '判断工作表的名称前5个字符是否为“第一题答案”，如果存在则激活该工作表并跳转到star行执行其下面的语句
  43.         If Left$(sht.Name, 5) = "第一题答案" Then sht.Activate: GoTo star
  44.     Next sht    '继续下一个
  45.     Sheets.Add after:=Worksheets("效果一")    '在工作表“效果一”后面新建一个工作表
  46.     shtname = "第一题答案_" & Application.Text(Timer - t, "0.000")    '将程序运行时间连接成一个字符串
  47.     ActiveSheet.Name = shtname    '重命名当前工作表名称

  49. star:
  50.     Range("a1").CurrentRegion.ClearContents    '清除单元格A1所在区域的内容
  51.     '将数组里的值赋值给单元格A1扩大1行12列的区域
  52.     Range("a1").Resize(1, 12) = Array("生产日期", "编号", "周期", "月份", "产品型号", "生产线", "班组", "不良类型", "不良位置", "不良数量", "备注", "产量")
  53.     '设置A列格式为日期格式
  54.     Range("a2").Resize(UBound(jg), 1).NumberFormat = "yyyy-m-d"
  55.     Range("a2").Resize(UBound(jg), UBound(jg, 2)) = jg    '区域赋值
  56.     Application.ScreenUpdating = True    '开启屏幕刷新
  57. End Sub

  59. Sub 作业二()
  60.     Dim dac As Object, dhc As Object
  61.     Dim arr, brr, jg, sj
  62.     Dim str As String
  63.     Dim i As Long, j As Long
  64.     Application.ScreenUpdating = False    '关闭屏幕刷新
  65.     Set dac = CreateObject("scripting.dictionary")    '创建字典对象
  66.     Set dhc = CreateObject("scripting.dictionary")    '创建字典对象
  67.     With Sheets("作业二")    '执行with语句
  68.         arr = .Range("a1").CurrentRegion    '将单元格A1所在的区域赋值给变量arr
  69.         brr = .Range("h1").CurrentRegion    '将单元格A1所在的区域赋值给变量brr
  70.         For i = 2 To UBound(arr)    '变量数组arr
  71.             '用逗号建立一个字符串并赋值给变量str
  72.             str = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4) & "," & arr(i, 5) & "," & arr(i, 6)
  73.             dac(str) = ""    '将字符串装入字典，其对应的项为空
  74.         Next i    '继续下一个
  75.         For i = 2 To UBound(brr)    '遍历数组brr
  76.             '用逗号建立一个字符串并赋值给变量str
  77.             str = brr(i, 1) & "," & brr(i, 2) & "," & brr(i, 3) & "," & brr(i, 4) & "," & brr(i, 5) & "," & brr(i, 6)
  78.             If dac.exists(str) Then dhc(str) = ""    '判断字典中是否存在字符串str，如存在，将字符串装入字典，其对应的项为空
  79.         Next i    '继续下一个
  80.         ReDim jg(1 To dhc.Count, 1 To 6)    '重新声明数组jg的大小
  81.         sj = dhc.keys    '将字典dhc中的关键字赋值给变量sj
  82.         For i = 1 To dhc.Count    '开始循环
  83.             For j = 1 To 6    '开始循环
  84.                 jg(i, j) = Split(sj(i - 1), ",")(j - 1)    '给数组jg赋值
  85.             Next j    '继续下一个
  86.         Next i    '继续下一个
  87.         .Range("o2:t" & dhc.Count).ClearContents    '清除内容
  88.         .Range("o2").Resize(dhc.Count, 6) = jg    '区域赋值
  89.     End With    '结束with语句
  90.     Set dac = Nothing    '清除字典释放内存
  91.     Set dhc = Nothing    '清除字典释放内存
  92.     Application.ScreenUpdating = True    '开启屏幕刷新
  93. End Sub

  95. Sub 作业二1()
  96.     Dim dac As Object
  97.     Dim arr, brr, jg
  98.     Dim str As String
  99.     Dim i As Long, j As Long
  100.     Application.ScreenUpdating = False '关闭屏幕刷新
  101.     Set dac = CreateObject("scripting.dictionary") '创建字典对象
  102.     With Sheets("作业二") '执行with语句
  103.         arr = .Range("a1").CurrentRegion '将单元格A1所在的区域赋值给变量arr
  104.         brr = .Range("h1").CurrentRegion '将单元格H1所在的区域赋值给变量brr
  105.         For i = 2 To UBound(arr) '遍历数组arr
  106.         '用逗号建立一个字符串并赋值给变量str
  107.             str = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4) & "," & arr(i, 5) & "," & arr(i, 6)
  108.             dac(str) = "" '将字符串装入字典，其对应的项为空
  109.         Next i '继续下一个
  110.         ReDim jg(1 To dac.Count, 1 To 6) '重新声明数组jg的大小
  111.         For i = 2 To UBound(brr) '变量数组brr
  112.         '用逗号建立一个字符串并赋值给变量str
  113.             str = brr(i, 1) & "," & brr(i, 2) & "," & brr(i, 3) & "," & brr(i, 4) & "," & brr(i, 5) & "," & brr(i, 6)
  114.             If dac.exists(str) Then '判断字典中是否存在字符串str
  115.                 j = j + 1 '计数器
  116.                 dac(str) = j '将字符串装入字典，其对应的项为变量j
  117.                 jg(j, 1) = brr(i, 1) '给数组jg赋值
  118.                 jg(j, 2) = brr(i, 2) '给数组jg赋值
  119.                 jg(j, 3) = brr(i, 3) '给数组jg赋值
  120.                 jg(j, 4) = brr(i, 4) '给数组jg赋值
  121.                 jg(j, 5) = brr(i, 5) '给数组jg赋值
  122.                 jg(j, 6) = brr(i, 6) '给数组jg赋值
  123.             End If '结束判断
  124.         Next i '继续下一个
  125.         .Range("o17:t" & dac.Count + 16).ClearContents '清除区域内容
  126.         .Range("o17").Resize(dac.Count, 6) = jg '区域赋值
  127.     End With '结束with语句
  128.     Set dac = Nothing '清空字典释放内存
  129.     Application.ScreenUpdating = True '开启屏幕刷新
  130. End Sub

  132. Sub 作业三()
  133.     Dim dac As Object
  134.     Dim arr, jg, ss
  135.     Dim str As String
  136.     Dim i As Long, j As Long
  137.     Application.ScreenUpdating = False    '关闭屏幕刷新
  138.     Set dac = CreateObject("scripting.dictionary")    '创建字典对象
  139.     With Sheets("作业三")    '执行with语句
  140.         arr = .Range("a1").CurrentRegion    '将单元格A1所在的区域赋值给变量arr
  141.         For i = 2 To UBound(arr)    '遍历数组arr
  142.             If arr(i, 1) = "湖北" Then    '判断数组第一列是否存在“湖北”
  143.                 '用逗号建立一个字符串并赋值给变量str
  144.                 str = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3)
  145.                 dac(str) = ""    '将字符串装入字典，其对应的项为变量j
  146.             End If    '结束判断
  147.             ReDim jg(1 To dac.Count, 1 To 3)    '重新声明数组jg的大小
  148.             ss = dac.keys    '将字典关键字赋值给变量ss
  149.             For i = 1 To dac.Count    '开始循环
  150.                 For j = 1 To 3    '开始循环
  151.                     jg(i, j) = Split(ss(i - 1), ",")(j - 1)    '给数组jg赋值
  152.                 Next j    '继续下一个
  153.             Next i    '继续下一个
  154.             .Range("e2:g" & dac.Count).ClearContents    '清除内容
  155.             .Range("e2").Resize(dac.Count, 3) = jg    '区域赋值
  156.         End With    '结束with语句
  157.         Set dac = Nothing    '清除字典释放内存
  158.         Application.ScreenUpdating = True    '开启屏幕刷新
  159.     End Sub

  161. Sub 作业三1()
  162.     Dim dac As Object
  163.     Dim arr, jg, ss
  164.     Dim str As String, zf As String
  165.     Dim i As Long, j As Long
  166.     Application.ScreenUpdating = False    '关闭屏幕刷新
  167.     Set dac = CreateObject("scripting.dictionary")    '创建字典对象
  168.     With Sheets("作业三")    '执行with语句
  169.         arr = .Range("a1").CurrentRegion    '将单元格A1所在的区域赋值给变量arr
  170.         zf = "湖北"    '将条件省名称“湖北”赋值给变量zf
  171.         ReDim jg(1 To UBound(arr), 1 To 3)    '重新声明数组jg的大小
  172.         For i = 2 To UBound(arr)    '遍历数组arr
  173.             '用逗号建立一个字符串并赋值给变量str和ss
  174.             str = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3)
  175.             ss = zf & "," & arr(i, 2) & "," & arr(i, 3)
  176.             If str = ss Then    '判断字符串str是否包含“湖北”的字符串
  177.                 dac(str) = ""    '装入字典，其对应的项为空
  178.             End If    '结束判断
  179.         Next i    '继续下一个
  180.         ss = dac.keys    '将字典关键字赋值给变量ss
  181.         For i = 1 To dac.Count    '遍历字典
  182.             For j = 1 To 3    '开始循环
  183.                 jg(i, j) = Split(ss(i - 1), ",")(j - 1)    '给数组jg赋值
  184.             Next j    '继续下一个
  185.         Next i    '继续下一个
  186.         .Range("e16:g" & UBound(jg) + 15).ClearContents    '清除内容
  187.         .Range("e16").Resize(UBound(jg), 3) = jg    '区域赋值
  188.     End With    '结束with语句
  189.     Set dac = Nothing    '清除字典释放内存
  190.     Application.ScreenUpdating = True    '开启屏幕刷新
  191. End Sub
复制代码
查看了好多帖子，终于做出了作业三的附加题。不易呀！
  1. '作业三附加题：三级下拉菜单
  2. Private Sub Worksheet_SelectionChange(ByVal Target As Range) '当工作表上的选定区域发生改变时触发程序
  3. '设置数据有效性的区域范围在I2：K20内，在其他区域操作时，不触发程序的运行
  4.     If Target.Count > 1 Then Exit Sub
  5.     If Target.Column <> 9 And Target.Column <> 10 And Target.Column <> 11 Then Exit Sub
  6.     If Target.Row < 2 Or Target.Row > 20 Then Exit Sub
  7.     '声明变量
  8.     Dim d As Object, d1 As Object
  9.     Dim arr
  10.     Dim i As Long, j As Long
  11.     '创建两个字典对象
  12.     Set d = CreateObject("scripting.dictionary")
  13.     Set d1 = CreateObject("scripting.dictionary")
  14.     '数组赋值
  15.     arr = Range("a1").CurrentRegion
  16.     '忽略错误继续执行
  17.     On Error Resume Next
  18.     '执行selete判断语句
  19.     Select Case Target.Column
  20.     Case Is = 9 '如果活动单元格在第9列（下同）
  21.         For i = 2 To UBound(arr) '遍历数组（下同）
  22.             d(arr(i, 1)) = "" '装入字典（下同）
  23.         Next i
  24.         With Target.Validation '数据有效性验证（下同）
  25.             .Delete '删除数据有效性（下同）
  26.             '创建新的数据有效性（下同）
  27.             .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
  28.                  Operator:=xlBetween, Formula1:=Join(d.keys, ",")
  29.         End With
  30.         '将二、三级菜单数据清除（可根据需要进行选择）
  31. '        Target.Offset(, 1) = ""
  32. '        Target.Offset(, 2) = ""
  33.         d.RemoveAll '清空字典，重新装入数据，防止出错（下同）
  34.     Case Is = 10
  35.         If Len(Target.Offset(, -1).Value) > 0 Then
  36.             For i = 2 To UBound(arr)
  37.                 k = arr(i, 1) & "," & arr(i, 2)
  38.                 d(k) = ""
  39.             Next i
  40.             For i = 2 To UBound(arr)
  41.                 If d.exists(Target.Offset(, -1).Value & "," & arr(i, 2)) Then d1(arr(i, 2)) = ""
  42.             Next i
  43.             With Target.Validation
  44.                 .Delete
  45.                 .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
  46.                      Operator:=xlBetween, Formula1:=Join(d1.keys, ",")
  47.             End With
  48.         End If
  49.         d.RemoveAll
  50.         d1.RemoveAll
  51.     Case Is = 11
  52.         If Len(Target.Offset(, -1).Value) > 0 Then
  53.             For i = 2 To UBound(arr)
  54.                 k = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3)
  55.                 d(k) = ""
  56.             Next i
  57.             For i = 2 To UBound(arr)
  58.                 If d.exists(Target.Offset(, -2).Value & "," & Target.Offset(, -1).Value & "," & arr(i, 3)) Then d1(arr(i, 3)) = ""
  59.             Next i
  60.             With Target.Validation
  61.                 .Delete
  62.                 .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
  63.                      Operator:=xlBetween, Formula1:=Join(d1.keys, ",")
  64.             End With
  65.         End If
  66.         Set d = Nothing '清除字典，释放内存
  67.         Set d1 = Nothing
  68.     End Select '结束判断
  69. End Sub
复制代码

点评

从从容容
总体是好的,都能按要求完成,但有的代码没有简化,  发表于 2013-11-28 10:45

评分

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

查看全部评分

回复

使用道具 举报

zjyxp
发表于 2013-11-25 22:50 | 显示全部楼层
本帖最后由 zjyxp 于 2013-11-25 22:59 编辑

【VBA字典数组201301班】B组 b05 zjyxp 第四讲作业上交,请学委老师指点，谢谢！
Option Explicit
Sub 作业一()
    Dim arr, brr
    Dim d1 As New Dictionary, d2 As New Dictionary, d3 As New Dictionary, d4 As New Dictionary
    Dim i As Long, j As Long, k As Long
    Dim Mystr1 As String, Mystr2 As String
    Dim T
    T = Timer '获取首先运行时间
    Sheets("源数据一").Activate '激活源数据一工作表
    '将指定区域数据装入数组
    arr = Sheets("源数据一").Range("a2:l" & Cells(Rows.Count, 1).End(xlUp).Row)
    '通过循环取得关键字符串
    For i = LBound(arr) To UBound(arr)
        For j = 1 To 8
            If j < 8 Then
                Mystr1 = Mystr1 & "/" & arr(i, j)
                Mystr2 = Mystr2 & "/" & arr(i, j)
            Else
                Mystr1 = Mystr1 & "/" & arr(i, j)
                Mystr2 = Mystr2
            End If
        Next j
            Mystr1 = Mid(Mystr1, 2, 99)
    '将关键字符串装入相关字典中
    If d1(Mystr1) = "" Then
        d1(Mystr1) = arr(i, 9)
    Else
        d1(Mystr1) = d1(Mystr1) & " " & arr(i, 9)
    End If
        d2(Mystr1) = d2(Mystr1) + arr(i, 10)
        d3(Mystr1) = arr(i, 11)
        d4(Mystr2) = arr(i, 12)
        Mystr1 = "": Mystr2 = ""
    Next i
    ReDim brr(1 To d1.Count, 1 To 12) '重置数组brr大小
    '通过循环从字典提取数据装入数组brr
    For i = 1 To UBound(brr)
        For j = 0 To 7
            brr(i, j + 1) = Split(d1.Keys(i - 1), "/")(j)
        Next j
            brr(i, 9) = d1.Items(i - 1)
            brr(i, 10) = d2.Items(i - 1)
            brr(i, 11) = d3.Items(i - 1)
            k = 2 * i - 1
            If k < 41 Then brr(k, 12) = d4.Items(i - 1)
    Next i
        Worksheets.Add after:=Sheets("作业一") '新增工作表
        ActiveSheet.Name = "第一题答案" & T - Timer '将新增工作表命名
        '将相关数据读入指定相关区域
        Range("a1:l1") = Array("生产日期", "编号", "周期", "月份", "产品型号", "生产线", "班组", "不良类型", "不良位置", "不良数量", "备注", "产量")
        [a2].Resize(UBound(brr), UBound(brr, 2)) = brr
        '修订A列数据日期格式
        Range("a2:a" & UBound(brr) + 1).NumberFormatLocal = "yyyy-m-d"
End Sub
Sub 作业二()
    Dim arr, brr, crr
    Dim d1 As New Dictionary, d2 As New Dictionary
    Dim i As Long, j As Long, k As Integer
    Dim str1 As String, str2 As String
    Worksheets("作业二").Activate '激活作业二工作表
    '将指定数据读入数组arr、brr
    arr = Range("a2:f" & Cells(Rows.Count, 1).End(xlUp).Row)
    brr = Range("h2:m" & Cells(Rows.Count, 8).End(xlUp).Row)
        For i = 1 To UBound(arr)
            str1 = arr(i, 1) & "/" & arr(i, 2) & "/" & arr(i, 3) & "/" & arr(i, 4) & "/" & arr(i, 5) & "/" & arr(i, 6)
            d1(str1) = "" '将相关数据装入字典
            str1 = ""
        Next i
        For j = 1 To UBound(brr)
            str2 = brr(j, 1) & "/" & brr(j, 2) & "/" & brr(j, 3) & "/" & brr(j, 4) & "/" & brr(j, 5) & "/" & brr(j, 6)
                If d1.Exists(str2) Then d2(str2) = "" '通过二个字典，判断二个数组共同数据并装入字典
                    str2 = ""
        Next j
    If d2.Count = 0 Then MsgBox "没有相同数据": Exit Sub
    ReDim crr(1 To d2.Count, 1 To 6)
    For i = 1 To UBound(crr)
        For j = 0 To 5
            crr(i, j + 1) = Split(d2.Keys(i - 1), "/")(j) '将共同数据读入数组crr
        Next j
    Next i
        Range("o2:t10000").ClearContents '清空指定区域
        [o2].Resize(UBound(crr), 6) = crr '将数组读入指定区域
End Sub

Sub 作业三()
Dim arr, brr, crr, drr
Dim d1 As New Dictionary, d2 As New Dictionary, d3 As New Dictionary
Dim i As Integer, j As Integer, k As Integer
Dim x As Integer, y As Integer
Worksheets("作业三").Activate     '激活作业三工作表
'指定区域装入数组arr
arr = Range("a2:c" & Cells(Rows.Count, 1).End(xlUp).Row)
'重置brr数组大小
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
'将湖北省相关市区装入数组brr
For i = 1 To UBound(arr)
    If arr(i, 1) = "湖北" And arr(i, 3) <> "" Then
        k = k + 1
        brr(k, 1) = arr(i, 1)
        brr(k, 2) = arr(i, 2)
        brr(k, 3) = arr(i, 3)
    End If
Next i
For i = 1 To k
    '将湖北市、区装入字典
    d1(brr(i, 1) & "#" & brr(i, 2) & "#" & brr(i, 3)) = ""
arr = d1.Keys '将字典的关键词装入数组
'重置数组crr与drr
ReDim crr(1 To UBound(arr) + 1, 1 To 3)
ReDim drr(1 To UBound(crr), 1 To 3)
'通过循环将字典数据读入数组crr
For i = 0 To UBound(arr)
    For j = 0 To 2
        crr(i + 1, j + 1) = Split(d1.Keys(i), "#")(j)
    Next j
    d2(crr(i + 1, 1) & "#" & crr(i + 1, 2)) = d2(crr(i + 1, 1) & "#" & crr(i + 1, 2)) & "#" & crr(i + 1, 3)
Next i
k = 0
'通过循环将数据据读入数组drr
For j = 1 To d2.Count
    For i = 1 To UBound(Split(d2.Items(j - 1), "#"))
        drr(k + 1, 1) = Split(d2.Keys(j - 1), "#")(0)
        drr(k + 1, 2) = Split(d2.Keys(j - 1), "#")(1)
        drr(k + 1, 3) = Split(d2.Items(j - 1), "#")(i)
        k = k + 1
    Next i
Next j
    Range("e2:g1000").ClearContents '清空指定区域
    [e2].Resize(UBound(drr), 3) = drr '将数组读入指定区域
End Sub


点评

从从容容
作业三,不能运行,循环有点乱但还是不错的.  发表于 2013-11-28 10:50

评分

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

查看全部评分

回复

使用道具 举报

ls
发表于 2013-11-26 00:49 | 显示全部楼层

  2. Option Explicit
  3. Sub 作业一()

  5. End Sub
  6. Sub 作业二()
  7.   Dim j&, i&, arr1, arr2, arr3, s1, s2, temp, brr
  8. Dim d1 As Object
  9. Set d1 = CreateObject("Scripting.Dictionary")
  10. Dim d2 As Object
  11. Set d2 = CreateObject("Scripting.Dictionary")
  12.   With Sheets("作业二")
  13.             arr1 = .[a1].CurrentRegion.Value
  14.     For i = 2 To UBound(arr1)
  15.         s1 = arr1(i, 1) & "|" & arr1(i, 2) & "|" & arr1(i, 3) & "|" & arr1(i, 4) & "|" & arr1(i, 5) & "|" & arr1(i, 6)
  16.             d1(s1) = ""
  17.     Next
  18.              arr2 = .[a2].CurrentRegion.Value
  19.     For i = 2 To UBound(arr2)
  20.         s2 = arr2(i, 1) & "|" & arr2(i, 2) & "|" & arr2(i, 3) & "|" & arr2(i, 4) & "|" & arr2(i, 5) & "|" & arr2(i, 6)
  21.            If d1(s2) = "" Then d2(s2) = ""
  22.     Next
  23.     arr3 = d2.keys
  24.    ReDim brr(UBound(arr3), 0 To 5)
  25.     If d2.Count Then
  26.     For j = 0 To UBound(arr3) - 1
  27.         temp = Split(arr3(j), "|")
  28.         For i = 0 To UBound(temp)
  29.             brr(j, i) = temp(i)
  30.         Next
  31.     Next
  32.     End If
  33.     .[o2].Resize(UBound(arr3), 6) = brr
  34.   End With
  35. End Sub
  36. Sub 作业三()
  37.     Dim arr, i%, j%, d, s, a, brr, temp
  38.     Set d = CreateObject("scripting.dictionary")
  39.     With Sheets("作业三")
  40.     arr = .[a1].CurrentRegion
  41.     For i = LBound(arr) To UBound(arr)
  42.     s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
  43.             d(s) = ""
  44.     Next
  45.     ReDim brr(UBound(arr) - 1, UBound(arr, 2) - 1)
  46.     If d.Count Then
  47.         a = d.keys
  48.         For j = 0 To UBound(a) - 1
  49.             temp = Split(a(j), "|")
  50.             For i = 0 To UBound(temp)
  51.                 brr(j, i) = temp(i)
  52.             Next
  53.         Next
  54.     End If
  55.     .[e1].Resize(UBound(arr), UBound(arr, 2)) = ""
  56.     .[e1].Resize(UBound(brr), UBound(arr, 2)) = brr
  57.     End With
  58. End Sub
复制代码

点评

从从容容
作业能按时完成,但代码有错,希望开贴后,看看别人的作业,提高自己.加油!  发表于 2013-11-28 10:55

评分

参与人数 1 +2 金币 +10 收起 理由
从从容容 + 2 + 10 加油

查看全部评分

回复

使用道具 举报

发表于 2013-11-27 16:52 | 显示全部楼层
b02 ： 望天打卦
Sub 作业一()
    Dim crr
    Dim arr, brr
    Dim d As Object
    Dim i As Integer, j As Integer, n As Integer, k As Integer
    Dim str As String
    Dim sh As Worksheet
    Set d = CreateObject("scripting.dictionary")
    ReDim brr(1 To 1000, 1 To 12)
    With Sheets("源数据一")
        crr = .Range("a1:l1")
        arr = .Range("a2:l" & .Cells(Rows.Count, 1).End(3).Row)  '数组写入数据
    End With
    For i = LBound(arr, 1) To UBound(arr, 1)
        str = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 5) & "|" & arr(i, 6) & "|" & arr(i, 7) & "|" & arr(i, 8) '字段组合形成key
        If d.Exists(str) Then          '判断如字典中存在此key，或者不存在key
            k = d(str)                 'k等因str key对应的item
            brr(k, 9) = brr(k, 9) & " " & arr(i, 9)    '数值brr的k行,9列的值 赋值
            brr(k, 10) = brr(k, 10) + arr(i, 10)        '数值brr的k行,10列的值 赋值
            brr(k + 1, 12) = ""
        Else
            n = n + 1
            d.Add str, n                 '字典d新增str,n
            For y = 1 To 12
                brr(n, y) = arr(i, y)    '数组循环赋值等于数值arr(i,Y)的值
            Next
        End If
    Next
   Worksheets.Add after:=Worksheets(Sheets.Count)       '新增工作表
   Set sh = ActiveSheet
    sh.Range("a1").Resize(1, 12) = crr
    sh.Range("a2").Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    sh.Columns(1).NumberFormatLocal = "yyyy-mm-dd"
    sh.Name = "第一题答案" & Format(Time, "hhmm")
End Sub
Sub 作业三()
    Dim d As Object, dk
    Dim arr, sh As Worksheet
    Dim i As Integer, j As Integer, k As Integer
    Dim str As String
    Set sh = Sheets("作业三")
    arr = sh.Range("a2:c" & Cells(Rows.Count, 1).End(3).Row)           '数组arr赋值
    Set d = CreateObject("scripting.dictionary")                       '建立字典d
    For i = 1 To UBound(arr, 1)
        If arr(i, 1) = "湖北" Then                                     '判断数组中的值是否等于湖北
        str = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
        End If
        If Not d.Exists(str) Then                                      '判断字典中是否有str的键值
            d.Add str, ""
            
        End If
    Next
    k = 2
    For Each dk In d.Keys                                              '字典中的keys中循环写入单元格
       sh.Cells(k, "e").Resize(1, 3) = Split(dk, "|")
        k = k + 1
    Next
    sh.Range("e2:g" & Cells(Rows.Count, "g").End(3).Row).Sort Range("e1"), xlDescending, Range("f1"), , xlDescending, Range("g1"), xlAscending
    End Sub

点评

从从容容
作业一和三做的很好,只是没有看到作业二,.  发表于 2013-11-28 11:13

评分

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

查看全部评分

回复

使用道具 举报

发表于 2013-11-27 16:54 | 显示全部楼层
B07:shanxiren
Option Explicit
Sub 作业一()
    Dim dStyle As New Dictionary
    Dim dNum As New Dictionary, dMemo As New Dictionary
    Dim dOutput As New Dictionary
    Dim arrKey(), arrValue(), arrOut(), arrtemp() As String, i&, j&
    Dim temp As String, t1, t2, key, sh As Worksheet
    '获得启动时时间
    t1 = Timer
    '将生产日期~不良类型组合后做为KEY
    arrKey = Sheet1.Range("a2:h" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row).Value
    arrValue = Sheet1.Range("i2:l" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row).Value
    For i = LBound(arrKey) To UBound(arrKey)
      key = Join(Application.Index(arrKey, i, 0), "||")
      '将不良位置放入dStyle的item中，并以" "分隔
      dStyle(key) = dStyle(key) & " " & arrValue(i, 1)
      '将数量放入dNum
      dNum(key) = dNum(key) + arrValue(i, 2)
      '将备注放入dMemo
      dMemo(key) = arrValue(i, 3)
      '将产量放入dOutput
      dOutput(key) = arrValue(i, 4)
    Next
    '重定义输出数组，并填入数据
   
    ReDim arrOut(1 To dStyle.Count, 1 To 12)
   

    i = 1
   
    For Each key In dStyle.Keys
      arrtemp = Split(key, "||")
      For j = LBound(arrtemp) To UBound(arrtemp)
        arrOut(i, j + 1) = arrtemp(j)
      Next
      arrOut(i, 9) = dStyle(key)
      

      If dNum.Exists(key) Then
        arrOut(i, 10) = dNum(key)
      End If
      If dMemo.Exists(key) Then
        arrOut(i, 11) = dMemo(key)
      End If
      If dOutput.Exists(key) Then
        arrOut(i, 12) = dOutput(key)
      End If
      
      i = i + 1
    Next
    '获得结束时时间
    t2 = Timer
    Set sh = ThisWorkbook.Sheets.Add
    sh.Name = "第一题答案-" & (t2 - t1)
    '写标题
    sh.Range("a1:l1") = Sheet1.Range("a1:l1")
    '将结果数组输出
    sh.Range("a2").Resize(UBound(arrOut, 1), UBound(arrOut, 2)).Value = arrOut
   
End Sub
Sub 作业二()
   Dim dA As New Dictionary, dB As New Dictionary, dC As New Dictionary
   Dim i&, key, j&
   Dim arrA(), arrB(), arrC()
   arrA = Range("a2:f" & Cells(Rows.Count, 1).End(xlUp).Row)
   arrB = Range("h2:m" & Cells(Rows.Count, "h").End(xlUp).Row)
   '将A区区域中的不重复数放入字典dA中
   For Each key In arrA
     dA(key) = ""
   Next
   '将B区区域中的不重复数放入字典dB中

   For Each key In arrB
     dB(key) = ""
   Next
   '将A区和B区中相同的数放入字典dC中
   For Each key In dA.Keys
     If dB.Exists(key) Then
       dC(key) = ""
     End If
   Next
   '以下根据相同的数字个数以6个为一行定义二维数组
   j = dC.Count / 6
   If dC.Count Mod 6 <> 0 Then j = j + 1
   ReDim arrC(1 To j, 1 To 6)
   i = 1
   j = 1
   For Each key In dC.Keys
     arrC(i, j) = key
     j = j + 1
     If j > 6 Then i = i + 1: j = 1
   Next
   '将结果写入指定区域
   Range("o2").Resize(UBound(arrC, 1), UBound(arrC, 2)).Value = arrC
End Sub
Sub 作业三()
    Dim dShen As New Dictionary, dShi As New Dictionary, dXian As New Dictionary
    Dim arr(), i&, key
    Dim shen$, shi$, xian$, temp, keyShi, keyXian
    arr = Range("a2:c" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    For i = LBound(arr) To UBound(arr)
        '将不重复县写入字典dXian,item值为“省 市”
        key = arr(i, 3)
        If key <> "" Then
            dXian(key) = arr(i, 1) & " " & arr(i, 2)
        End If
        '得到不重复的省写入字典dShen
        key = arr(i, 1)
        dShen(key) = ""
        '得到不重复的市写入字典dShi,item值为“省”
        key = arr(i, 2)
        dShi(key) = arr(i, 1)
    Next
    i = 2
    '遍历省字典，查找市县字典，组合省市县值写入单元格中
    For Each key In dShen.Keys
      For Each keyShi In dShi.Keys
        If dShi(keyShi) = key Then
            shen = key
            shi = keyShi
            temp = shen & " " & shi
            For Each keyXian In dXian.Keys
               If dXian(keyXian) = temp Then
                 xian = keyXian
                 Cells(i, "e") = shen
                 Cells(i, "f") = shi
                 Cells(i, "g") = xian
                 i = i + 1
               End If
            Next
        End If
      Next
    Next

End Sub

点评

从从容容
第二题,没能做出来,但总体是不错的.  发表于 2013-11-28 11:19

评分

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

查看全部评分

回复

使用道具 举报

zmnyu
发表于 2013-11-28 00:18 | 显示全部楼层
本帖最后由 zmnyu 于 2013-11-28 01:12 编辑

不好意思来晚了，终于做完了，可以睡觉啦，谢谢老师批改！

B03-zmnyu

第一题：
  1. Sub 作业一()
  2.     Dim arr(), brr(), str As String
  3.     Dim d1 As New Dictionary, d2 As New Dictionary, d3 As New Dictionary, d4 As New Dictionary
  4.     Dim i As Integer, n As Integer
  5.     Dim newsht As Worksheet
  6.     arr() = Sheets("源数据一").UsedRange.Value
  7.     '源数据装入数组arr
  8.     For i = 1 To UBound(arr)
  9.         str = "" '把字符串str清空
  10.         For j = 1 To 8
  11.             str = str & "-" & arr(i, j)
  12.             '把每行的前八列用“-”连接，赋值给str
  13.         Next j
  14.         str = Mid(str, 2, 99)  '去掉str中第一个“-”
  15.         d1(str) = d1(str) & arr(i, 9) & " "
  16.         '字典d1(str)存放所有“不良位置”，并用空格隔开
  17.         d2(str) = d2(str) + arr(i, 10)
  18.         '字典d2存放不良数量的总和
  19.         d3(str) = arr(i, 11)
  20.         '字典d3存放最后一个备注
  21.         If arr(i, 8) = "假焊" Then
  22.             '如果“不良类型”为：“假焊”
  23.             d4(str) = arr(i, 12)
  24.             '则字典d4存放产量
  25.         Else ' 否则
  26.             d4(str) = ""
  27.             '字典d4的item值为空
  28.         End If

  30.     Next i
  31.     Set newsht = Sheets.Add '建立新工作表，指定给newsht
  32.     newsht.Name = "第一题答案-" & Format(Now, "hhmm")
  33.     '重命名工作表
  34.     '下面为批量输出结果到新工作表，前八列为先把字典d1的keys值输出到A列，然后再按“-”进行分列
  35.     With newsht
  36.         .Range("A1").Resize(d1.Count, 1) = Application.Transpose(d1.Keys)
  37.         .Range("I1").Resize(d1.Count, 1) = Application.Transpose(d1.Items)
  38.         .Range("J1").Resize(d1.Count, 1) = Application.Transpose(d2.Items)
  39.         .Range("K1").Resize(d1.Count, 1) = Application.Transpose(d3.Items)
  40.         .Range("L1").Resize(d1.Count, 1) = Application.Transpose(d4.Items)
  41.         .[L1] = "产量"
  42.        .Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
  43.                                       TextQualifier:=xlDoubleQuote, _
  44.                                        Other:=True, OtherChar:="-", FieldInfo:=Array(Array(1, 1), _
  45.                                        Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), _
  46.                                        Array(6, 1), Array(7, 1), Array(8, 1)), TrailingMinusNumbers:=True
  47.         .Columns("A:L").EntireColumn.AutoFit
  48.     End With
  49. End Sub
复制代码
第二题：
  1. Sub 作业二()
  2.     t = Timer
  3.     Dim arr1(), d1 As New Dictionary, key1 As String
  4.     Dim arr2(), d2 As New Dictionary
  5.     Dim arr3()
  6.     Dim i As Long, n As Long
  7.     n = Range("A65536").End(xlUp).Row
  8.     '取数据最大行号，赋值给n
  9.     arr1() = Range("A2:F" & n).Value
  10.     arr2() = Range("H2:M" & n).Value
  11.     '源数据分别装入数组arr1和arr2
  12.     For i = 1 To n - 1
  13.         For j = 1 To 6
  14.             key1 = key1 & "-" & arr1(i, j)
  15.             '把arr1中每行的六个数字用“-”连接，赋值给key1
  16.         Next j
  17.         d1(key1) = ""
  18.        ' 指定字典d1中以字符串key1为key的item值为 空
  19.         key1 = ""  '把字符串key1清空，以备下次循环时使用
  20.     Next i
  21.     For i = 1 To n - 1
  22.         For j = 1 To 6
  23.             key2 = key2 & "-" & arr2(i, j)
  24.              '把arr2中每行的六个数字用“-”连接，赋值给key2
  25.         Next j
  26.         If d1.Exists(key2) Then
  27.             '如果字典d1中有以字符串key2这个key
  28.             ReDim Preserve arr3(k)
  29.              '重新定义数组arr3的大小
  30.             arr3(k) = Split(key2, "-")
  31.             '把字符串key2拆分后装入到数组arr3(k)(即符合条件的六个数字)
  32.             k = k + 1
  33.         End If
  34.         key2 = ""    '把字符串key2清空，以备下次循环时使用
  35.     Next i
  36.     Range("N2:T" & UBound(arr3) + 1) = Application.Transpose(Application.Transpose(arr3))
  37.     '把数组arr3合理转置后输出到结果区域
  38.     MsgBox "运行时间  " & Format(Timer - t, "0.000000") & "秒" '对话框显示运行时间
  39. End Sub
复制代码
第三题：
  1. Sub 作业三()
  2.     Dim arr(), brr(), d As New Dictionary
  3.     Dim i As Byte, key1 As String
  4.     arr() = Range("A2:C25")
  5.      '把数据区域装入数组arr
  6.     For i = 1 To UBound(arr)
  7.         If arr(i, 3) <> "" Then
  8.           '如果第三列不为空
  9.                     key1 = arr(i, 1) & "-" & arr(i, 2) & "-" & arr(i, 3)
  10.                     '把三列以“-”号连接，赋值给key1
  11.             If Not d.Exists(key1) Then
  12.                 '如果字典中不存在这个key
  13.                 d(key1) = key1
  14.                     '建立新条目，key值和item值均为字符串key1
  15.                 ReDim Preserve brr(k)
  16.                     '重定义数组brr的大小
  17.                 brr(k) = Split(d(key1), "-")
  18.                     '把d(key1)拆分后，装入数组
  19.                 k = k + 1
  20.             End If
  21.         End If
  22.     Next i
  23.     Range("E2").Resize(k, 3) = Application.Transpose(Application.Transpose(brr))
  24. End Sub
复制代码

点评

从从容容
作业一,运行不点小问题,其余的两题不错,  发表于 2013-11-28 11:27

评分

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

查看全部评分

回复

使用道具 举报

发表于 2013-11-28 11:44 | 显示全部楼层
  1. Sub 作业三()
  2. Dim i, j
  3. Dim arr, arr1(1 To 10000, 1 To 3)
  4. Dim d As New Dictionary    '定义变量 d 为  新的 字典
  5. With Sheet7    '工作于Sheet7
  6.     arr = .Range("a2:c" & .Range("a65536").End(xlUp).Row)
  7.    
  8.     For i = 1 To UBound(arr)    '设定变量范围为i=1到<数组上限>(arr)
  9.    
  10.         If arr(i, 3) <> "" And arr(i, 1) = "湖北" Then    '如果 arr(i,3) 不等于 空值 并且 arr(i,1)="湖北" 则执行
  11.         
  12.             If d.Exists(arr(i, 1) & arr(i, 2) & arr(i, 3)) = False Then    '如果  d的存在arr(i,1) & arr(i,2) & arr(i,3))=False 则执行
  13.                
  14.                  d(arr(i, 1) & arr(i, 2) & arr(i, 3)) = d.Count + 1    'd(arr(i,1) & arr(i,2) & arr(i,3))= d的计数值+1
  15.                
  16.                 For j = 1 To UBound(arr, 2)    '设定变量范围为j=1到<数组上限>(arr,2)
  17.                     
  18.                     arr1(d.Count, j) = arr(i, j)    'arr1( d的计数值,j)=arr(i,j)
  19.                
  20.                 Next j
  21.             
  22.             End If
  23.         
  24.         End If
  25.    
  26.     Next i
  27.     .Range("e2").Resize(d.Count, 3) = arr1    '<With对象>的<单元格>区域("e2" )的<重调大小>( d的计数值,3)=arr1
  28. End With    'With语句结束
  29. End Sub
复制代码
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-5-2 10:26 , Processed in 0.407522 second(s), 16 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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