常见字典用法集锦及代码详解

风云际会6

学习，不是为灌水，只为有个地儿

LZP2991693

好帖，感谢楼主的付出啊

LMY123

好东西，今天才看到，准备花一个月好好学习，谢谢 蓝桥玄霜版主的分享

mjzxlmg

蓝桥玄霜 发表于 2010-10-18 12:56
实例11  关键字赋给两列后用Replace方法
一、问题的提出：
有如图实例11-1所示的工资表，要求编写一段代码 ...

近几天无事，研究了一下字典用法，重写了一下“实例11  关键字赋给两列后用Replace方法”这个例子的代码，代码简洁明了。献丑了。


[code=vb]Sub 我的代码()
Dim arr, d As Object, i&, j&, m&, s&, brr()
Set d = CreateObject("Scripting.Dictionary")
With Sheet1
   arr = .[a1].CurrentRegion.Value
ReDim brr(1 To 1000, 1 To UBound(arr, 2) / 3 + 2)
m = 1
For j = 1 To UBound(arr, 2) Step 3
      For i = 2 To UBound(arr)
            If Len(arr(i, j)) Then     '排除空白行
               s = d(arr(i, j) & arr(i, j + 1))       '性别+姓名作为关键字
               If s = Empty Then
                  m = m + 1
                  d(arr(i, j) & arr(i, j + 1)) = m
                  s = m                                     '取得关键字位置
                  brr(s, 1) = arr(i, j)                    '性别
                  brr(s, 2) = arr(i, j + 1)                  '姓名
              End If
              brr(s, (j - 1) / 3 + 3) = arr(i, j + 2)   '各月工资
           End If
      Next
      brr(1, (j - 1) / 3 + 3) = arr(1, j + 2)   '表头：各月工资
Next
   brr(1, 1) = Right$(arr(1, 1), 2)   '表头：性别
   brr(1, 2) = Right$(arr(1, 2), 2)   '表头：姓名
   .[a12].CurrentRegion.ClearContents
   .[a12].Resize(m, UBound(brr, 2)) = brr
End With
Set d = Nothing
End Sub[/code]

实例附件：
实例11_两列Replace.rar (15.73 KB, 下载次数: 71)

2012-6-17 10:28 上传

点击文件名下载附件

wty111

谢谢蓝版主，先下了，以后学，现在还只懂一点，一步一步来，

355177807

看到有这么多回帖在前面，才知道有这么多人已经比我更厉害了

LMY123

请问版主，我模仿你的实例9的代码
想得到结果如下

试件编号                                                                                       部位
H-001 H-002 H-003 H-004 H-005 H-006 HST-007                              1区底板
H-008 H-009 H-010 H-011 H-012 H-013 H-014 H-015 HST-016              2区底板

结果却是：
试件编号                                                                                            部位
H-001 H-002 H-003 H-004 H-005 H-006 HST-007                               1区底板
H-008                                                                                        2区底板

代码如下：
Sub yy()
Dim d As New Dictionary, R
Dim k, i&, j&
R = Sheet1.UsedRange
k = 1
For i = 2 To UBound(R)
    R(i, 2) = Replace(Replace(R(i, 2), "（", "("), "）", ")")
    If d.Exists(R(i, 2)) Then
        R(d(R(i, 2)), 1) = R(d(R(i, 2)), 1) & " " & R(i, 1)
    Else
        k = k + 1
        d(R(i, 2)) = i
        For j = 1 To UBound(R, 2)
            R(k, j) = R(i, j)
        Next
  End If
Next
With Sheet2
    .Cells.ClearContents
    .Cells.Borders.LineStyle = xlNone
    .[A1:B2].Resize(d.Count + 1) = R
    .[A1:B2].Resize(d.Count + 1).Borders.LineStyle = 1
End With
Set d = Nothing
End Sub
附件如下
03-22---实例9_字典取行数组重新赋值.rar (15.46 KB, 下载次数: 26)

2012-3-22 10:09 上传

点击文件名下载附件

LMY123

对不起，说错了，其它朋友也可以回答。特此更正。

lhx120824

谢谢分享，下载学习。

mjzxlmg

lhx120824 发表于 2012-3-22 17:03
谢谢分享，下载学习。

函数大师也来了。