[已解决]字典代码解惑，请各位老师帮忙！

gwfzh · 发表于 2010-12-18 15:25

代码解惑，请各位老师帮忙！

下面是AVEL老师帮忙写的程序代码，但代码中有些语句不太明白，希望各位老师能帮忙能解释一下！在此先谢谢了！
Sub L()
Dim arr, brr, crr, drr(), q(), k%
Dim dic As Object
On Error Resume Next
Application.ScreenUpdating = False
Sheets(1).Range("E5:BY65536").ClearContents
arr = Sheets(2).Range("A4", Sheets(2).[X65536].End(3))  '取得原始数据
brr = Sheets(1).Range("A5", Sheets(1).[A65536].End(3))  '取得表一a列的各地址
crr = Sheets(1).Range("e2", Sheets(1).[by2].End(1))    '取得表一的各疾病表头：不懂为什么要用“[by2].”？
Set dic = CreateObject("scripting.dictionary")
For m = 1 To UBound(crr, 2)
dic(crr(1, m)) = 0                   '为什么要赋值为"0"?
Next m
k = 1
For i = 1 To UBound(arr)
If Not dic.exists(arr(i, 24)) Then  '这里的字典变量dic与上面dic(crr(1, m))的字典变量有什么区别？为什么一个字典dic能反复运用？
      dic(arr(i, 24)) = 0
      ReDim Preserve q(1 To k)
      q(k) = arr(i, 24)
      k = k + 1
End If
Next
If Not IsEmpty(q) Then Sheets(1).[by2].End(1).Offset(, 1).Resize(UBound(q)) = q  ' 该句起什么作用？
crr = Sheets(1).Range("e2", Sheets(1).[by2].End(1))                            'crr数组不是已有了吗？下面的dic(crr(1, m)) = 0字典循环不是在前面已运行了吗，不明白为什么还要反复的运用？
ReDim drr(1 To UBound(brr), 1 To UBound(crr, 2))
For i = 1 To UBound(brr)                                                          '该字典循环不是在上面第一个已循环了吗？为什么还要执行一次？
Set dic = CreateObject("scripting.dictionary")                               '为什么还要set dic?该dic与上面的有什么不同？
For m = 1 To UBound(crr, 2)
      dic(crr(1, m)) = 0
Next m
For j = 1 To UBound(arr)
      If InStr(1, arr(j, 13), Trim(brr(i, 1))) Then
         dic(arr(j, 24)) = dic(arr(j, 24)) + 1
      End If
Next j
For n = 1 To UBound(crr, 2)
      drr(i, n) = dic(crr(1, n))                      '不明白这句是什么意思？
Next n
Set dic = Nothing
Next i
Sheets(1).[E5].Resize(UBound(brr), UBound(crr, 2)) = drr
Application.ScreenUpdating = True
MsgBox "DONE!!!!!"
End Sub

[此贴子已经被作者于2010-12-18 15:25:25编辑过]

最佳答案

月排行榜 / 总排行榜

wxyqxxz2007

2010-12-20 13:32

Sub yy()
    Dim d As Object, brr(), arr
    Dim i As Long, r As Long, c As Long
    Dim ar, crr(), k As Long, j As Long
    Dim s As String, br
    Set d = CreateObject("scripting.dictionary")
    With Sheets("Sheet1")
        r = .Range("a65536").End(xlUp).Row
        c = .Range("iv3").End(xlToLeft).Column
        ar = .Range("a3").Resize(r - 2, c)
    End With
    For i = 5 To UBound(ar, 2)
        d(ar(1, i)) = i
    Next
    With Sheets("Sheet2")
        r = .Range("a65536").End(xlUp).Row
        c = .Range("iv3").End(xlToLeft).Column
        br = .Range("a4").Resize(r - 3, c)
    End With
    ReDim brr(1 To UBound(br))
    For i = 1 To UBound(br)
        brr(i) = br(i, 13) & "][" & br(i, 24)
    Next
    ReDim crr(1 To UBound(ar) + 1, 1 To UBound(ar, 2) - 3)
    For i = 4 To UBound(ar)
        arr = Filter(brr, Trim(ar(i, 1)), 1)
        If UBound(arr) <> -1 Then
            k = k + 1
            For j = 0 To UBound(arr)
                s = Split(arr(j), "][")(1)
                If d.exists(s) Then
                    crr(k + 1, d(s) - 3) = crr(k + 1, d(s) - 3) + 1
                    crr(1, d(s) - 3) = crr(1, d(s) - 3) + 1
                End If
            Next
            crr(k + 1, 1) = UBound(arr) + 1
            crr(1, 1) = crr(1, 1) + crr(k + 1, 1)
        End If
    Next
    Sheets("Sheet1").Range("d5").Resize(k + 1, UBound(ar, 2) - 3) = crr
End Sub

跳转到最佳答案楼层

走进EXCEL · 发表于 2010-12-18 23:58

你不传附件，老师们就搞不懂你的意图啦！

请传附件，并说明需求。

gwfzh · 发表于 2010-12-19 09:57

QUOTE:

以下是引用走进EXCEL在2010-12-18 23:58:00的发言：

你不传附件，老师们就搞不懂你的意图啦！

请传附件，并说明需求。

要求是在sheet2表的m列（现住详细地址）查找sheet1表的a列的各乡镇单位、如找到的话，则按sheet1表第二行的疾病分类对sheet2表x列（疾病编号）进行发病统计。不知说清楚没有？ Foauzqdf.rar (320.84 KB, 下载次数: 11)

那么的帅 · 发表于 2010-12-19 10:07

楼主，1楼看的有些乱，请把需要解释的代码，用红色字体标注一下，可以吗？

gwfzh · 发表于 2010-12-19 11:49

QUOTE:

以下是引用那么的帅在2010-12-19 10:07:00的发言：

楼主，1楼看的有些乱，请把需要解释的代码，用红色字体标注一下，可以吗？

Sub L()
Dim arr, brr, crr, drr(), q(), k%
Dim dic As Object
On Error Resume Next
Application.ScreenUpdating = False
Sheets(1).Range("E5:BY65536").ClearContents
arr = Sheets(2).Range("A4", Sheets(2).[X65536].End(3)) '取得原始数据
brr = Sheets(1).Range("A5", Sheets(1).[A65536].End(3)) '取得表一a列的各地址
crr = Sheets(1).Range("e2", Sheets(1).[by2].End(1))     '取得表一的各疾病表头：不懂为什么要用“[by2].”？
Set dic = CreateObject("scripting.dictionary")
For m = 1 To UBound(crr, 2)
    dic(crr(1, m)) = 0                    ' 在字典中添加表1中每个病种的名称，并将计数值初始化为0
Next m
k = 1
For i = 1 To UBound(arr)
    If Not dic.exists(arr(i, 24)) Then ''在这里判断表2中出现的病名在字典中是否存在,不存在则添加到字典中,也将计数值初始化为0,并加入一维数组q中
        dic(arr(i, 24)) = 0
        ReDim Preserve q(1 To k)
        q(k) = arr(i, 24)
        k = k + 1
    End If
Next
If Not IsEmpty(q) Then Sheets(1).[by2].End(1).Offset(, 1).Resize(UBound(q)) = q '若数组q不为空说明表2中存在表1中所没有的病名,
                                                                                ' 于是就将新增的病名添加到表1中去,追加在第2行后面的列中
                                                                                 '如果q不为空，后面的crr就与第一次的crr不一样了，当然后面的字典也就不一样了，所以要重新来一次。
                                                                                 '如果q是空的，那crr,字典和之前的是一样的。

crr = Sheets(1).Range("e2", Sheets(1).[by2].End(1))                              '因为经过上面的操作,表1的病名列表可能更新,因此再一次的给crr赋值,是为了增加新增的病名
ReDim drr(1 To UBound(brr), 1 To UBound(crr, 2))
For i = 1 To UBound(brr)                                                           '该字典循环不是在上面第一个已循环了吗？为什么还要执行一次？
    Set dic = CreateObject("scripting.dictionary")                                 '为什么还要set dic?该dic与上面的有什么不同？
                                                                                   '注意这是在遍历表2的每个地名,每次得到一行数据,每行数据对应一个地名中所有病种的统计
                                                                                       ' 情况 , 因此在统计前有必要将字典中的统计值清零
   For m = 1 To UBound(crr, 2) '在前面的第二个循环If Not dic.exists(arr(i, 24)) Then中不是已加了?我试着去掉该小循环后怎么得出的结果是不变？        dic(crr(1, m)) = 0
    Next m
    For j = 1 To UBound(arr)
        If InStr(1, arr(j, 13), Trim(brr(i, 1))) Then
            dic(arr(j, 24)) = dic(arr(j, 24)) + 1
        End If
    Next j
    For n = 1 To UBound(crr, 2)
        drr(i, n) = dic(crr(1, n))   '这句的意思是将每行统计数据写入记录最终结果的数组drr中,dic(crr(1, n)) 就是读取字典
                                                           '           中病名为 crr(1, n)的统计数据,而crr数组存放的就是表1中各个病名的数组
                                     '仍不太理解！dic(arr(j, 24))是条目值的累加，中间没有通过赋值给dic(crr(1, n)) ，dic(crr(1, n))也应是条目值啊。
    Next n
    Set dic = Nothing
Next i
Sheets(1).[E5].Resize(UBound(brr), UBound(crr, 2)) = drr
Application.ScreenUpdating = True
MsgBox "DONE!!!!!"
End Sub

谢谢那么的帅老师：现仅剩2个问题了（见红色标注部分）：

1、程序中是否要通过红色代码部分重新循环一次，加入新的键值。但在前面第二个循环 If Not dic.exists(arr(i, 24)) Then中不是已加了吗？我试着去掉该小循环后怎么不影响结果呢？得出的结果是一样的！
For m = 1 To UBound(crr, 2)
dic(crr(1, m)) = 0
Next m
2、另外： drr(i, n) = dic(crr(1, n)) 中的dic(crr(1, n))就是dic(arr(j, 24)) = dic(arr(j, 24)) + 1的计数结果吗？不太理解！dic(arr(j, 24))是条目值的累加，中间没有通过赋值给dic(crr(1, n)) ，dic(crr(1, n))也应是条目值啊。

青城山苦丁茶 · 发表于 2010-12-19 12:07

这代码是你所需要的吗？有点怪，好多地方得改。下面仅作一点点注释：

Sub L()
Dim arr, brr, crr, drr(), q(), k%
Dim dic As Object
On Error Resume Next
Application.ScreenUpdating = False
Sheets(1).Range("E5:BY65536").ClearContents
arr = Sheets(2).Range("A4", Sheets(2).[X65536].End(3))
brr = Sheets(1).Range("A5", Sheets(1).[A65536].End(3))
crr = Sheets(1).Range("e2", Sheets(1).[by2].End(1))     '就是从e2起到最后一个有值的列，Sheets(1).[by2].End(1)，就是说填有内容的不会达到[by2]。当然你也可以再往后移，变成[iv2]都行。
Set dic = CreateObject("scripting.dictionary")
For m = 1 To UBound(crr, 2)
    dic(crr(1, m)) = 0                    '赋值为"0"不具实际意义，只起个将病的名称（sheet1中的病名）去重复、加入字典的作用。将它改成=1、=""、="什么"都行
Next m
k = 1
For i = 1 To UBound(arr)
    If Not dic.exists(arr(i, 24)) Then '这里是看该病的名称（sheet2中的每一个病名）在字典中是否已存在，如果是新出现的，则将它加入到字典中，并记录在数组q中
        dic(arr(i, 24)) = 0
        ReDim Preserve q(1 To k)
        q(k) = arr(i, 24)
        k = k + 1
    End If
Next
If Not IsEmpty(q) Then Sheets(1).[by2].End(1).Offset(, 1).Resize(, UBound(q)) = q '这里原代码有错，需改一点,如果有新的病名出现（相对于sheet1，在sheet2中有新的病名出现）则将其添加到sheet1中
crr = Sheets(1).Range("e2", Sheets(1).[by2].End(1))                              '既然上一句可能会有新的病名添加到sheet1，所以他这里对crr数组重新赋值
ReDim drr(1 To UBound(brr), 1 To UBound(crr, 2))

For i = 1 To UBound(brr)
   ' Set dic = CreateObject("scripting.dictionary")                                 '这四行确实是多余了，可删除
   ' For m = 1 To UBound(crr, 2)
   '     dic(crr(1, m)) = 0
   ' Next m

    For j = 1 To UBound(arr)             'sheet1的“现住地址国标编码”与sheet2的“现住详细地址”是不存在内含关系的，因此这个循环起什么作用？不明白原作者意图
        If InStr(1, arr(j, 13), Trim(brr(i, 1))) Then
            dic(arr(j, 24)) = dic(arr(j, 24)) + 1
        End If
    Next j
    For n = 1 To UBound(crr, 2)     '这个循环也有点奇怪，他是给数组drr赋0值。为什么不直接清空呢？
        drr(i, n) = dic(crr(1, n))
    Next n
   ' Set dic = Nothing   '这句得往下移，移到next i 后面
Next i
Set dic = Nothing
Sheets(1).[E5].Resize(UBound(brr), UBound(crr, 2)) = drr
Application.ScreenUpdating = True
MsgBox "DONE!!!!!"
End Sub

青城山苦丁茶 · 发表于 2010-12-19 12:10

不成熟的代码会令人越看越晕的，最好写清需求，请朋友们重新给你写个既符合要求又简明扼要的代码吧。[em07][em07][em07]

gwfzh · 发表于 2010-12-19 14:14

QUOTE:

以下是引用青城山苦丁茶在2010-12-19 12:10:00的发言：
不成熟的代码会令人越看越晕的，最好写清需求，请朋友们重新给你写个既符合要求又简明扼要的代码吧。[em07][em07][em07]

谢谢青城山苦丁茶老师！

要求是在sheet2表的m列（现住详细地址）查找sheet1表的a列的各乡镇单位、如找到的话，则按sheet1表第二行的疾病分类对sheet2表x列（疾病编号）进行发病统计。不知说清楚没有？现传上附件和要求！

2ZfXK9J2.rar (322.21 KB, 下载次数: 0)

青城山苦丁茶 · 发表于 2010-12-19 21:41

按个人理解改写的，试下看符合要求不：

Sub L()
Dim arr, brr, crr, drr(), q(), k%, i%, m%
Dim dic As Object
On Error Resume Next
Application.ScreenUpdating = False
With Sheets(1)
   .Range("d4:BY65536").ClearContents     '从d4起的所有单元格内容清除
   .Range("e2:BY3").ClearContents         '从e2起的表头内容清除
   brr = .Range("A2:d" & .[A65536].End(3).Row)    'a列内容读入数组brr
End With
arr = Sheets(2).Range("m4", Sheets(2).[X65536].End(3)) '统计只涉及M列和x列
Set dic = CreateObject("scripting.dictionary")
For m = 4 To UBound(brr)        'sheet1中的乡镇名有多余的空格，去除
    brr(m, 1) = Trim(brr(m, 1))
Next m
k = 4
For i = 1 To UBound(arr)
    If Not dic.exists(arr(i, 12)) Then '这里是看该病的名称（sheet2中的每一个病名）在字典中是否已存在，如果是新出现的，则将它加入到字典中，并记录在结果数组brr中
        k = k + 1
        If UBound(brr, 2) < k Then ReDim Preserve brr(1 To UBound(brr), 1 To 10 + k)   '如果结果数组brr列数不够，则增加
        brr(1, k) = arr(i, 12)   '表头：病的名称
        brr(2, k) = "发病数"
        dic(arr(i, 12)) = k    '记录下该病在数组brr中所在的列
    End If
    For m = 4 To UBound(brr)
        If InStr(arr(i, 1), brr(m, 1)) Then
           brr(m, dic(arr(i, 12))) = brr(m, dic(arr(i, 12))) + 1 '该乡镇、该病加1
           brr(3, dic(arr(i, 12))) = brr(3, dic(arr(i, 12))) + 1 '该病加1,即sheet1的第四行
           brr(m, 4) = brr(m, 4) + 1   '该乡镇加1，即sheet1的D列
           brr(3, 4) = brr(3, 4) + 1   'sheet1的D4加1
           Exit For
        End If
    Next
Next
Sheets(1).[a2].Resize(UBound(brr), k) = brr
Application.ScreenUpdating = True
MsgBox "DONE!!!!!"
End Sub

gwfzh · 发表于 2010-12-20 09:52

QUOTE:

以下是引用青城山苦丁茶在2010-12-19 21:41:00的发言：

按个人理解改写的，试下看符合要求不：

Sub L()
Dim arr, brr, crr, drr(), q(), k%, i%, m%
Dim dic As Object
On Error Resume Next
Application.ScreenUpdating = False
With Sheets(1)
   .Range("d4:BY65536").ClearContents     '从d4起的所有单元格内容清除
   .Range("e2:BY3").ClearContents         '从e2起的表头内容清除
   brr = .Range("A2:d" & .[A65536].End(3).Row)    'a列内容读入数组brr
End With
arr = Sheets(2).Range("m4", Sheets(2).[X65536].End(3)) '统计只涉及M列和x列
Set dic = CreateObject("scripting.dictionary")
For m = 4 To UBound(brr)        'sheet1中的乡镇名有多余的空格，去除
    brr(m, 1) = Trim(brr(m, 1))
Next m
k = 4
For i = 1 To UBound(arr)
    If Not dic.exists(arr(i, 12)) Then '这里是看该病的名称（sheet2中的每一个病名）在字典中是否已存在，如果是新出现的，则将它加入到字典中，并记录在结果数组brr中
        k = k + 1
        If UBound(brr, 2) < k Then ReDim Preserve brr(1 To UBound(brr), 1 To 10 + k)   '如果结果数组brr列数不够，则增加
        brr(1, k) = arr(i, 12)   '表头：病的名称
        brr(2, k) = "发病数"
        dic(arr(i, 12)) = k    '记录下该病在数组brr中所在的列
    End If
    For m = 4 To UBound(brr)
        If InStr(arr(i, 1), brr(m, 1)) Then
           brr(m, dic(arr(i, 12))) = brr(m, dic(arr(i, 12))) + 1 '该乡镇、该病加1
           brr(3, dic(arr(i, 12))) = brr(3, dic(arr(i, 12))) + 1 '该病加1,即sheet1的第四行
           brr(m, 4) = brr(m, 4) + 1   '该乡镇加1，即sheet1的D列
           brr(3, 4) = brr(3, 4) + 1   'sheet1的D4加1
           Exit For
        End If
    Next
Next
Sheets(1).[a2].Resize(UBound(brr), k) = brr
Application.ScreenUpdating = True
MsgBox "DONE!!!!!"
End Sub

谢谢青城山苦丁茶老师！可是疾病的顺序打乱了，因为有些疾病是要按病毒性肝炎、疟疾、结核等分类后再小计，只是为了方便写代码没有在表一中列出，现补上内容把附件重新传上，请再帮助！

tx5qWatt.rar (329.03 KB, 下载次数: 19)

		自动登录	找回密码
密码			注册

[已解决]字典代码解惑，请各位老师帮忙！

代码解惑，请各位老师帮忙！

怎样按sheet2表的m列（现住详细地址）和x列（疾病编号）进行发病地区的统计？