【VBA字典数组201301班】D组- 第三讲作业上交处

sliang28 · 发表于 2013-11-14 21:26

本帖最后由 sliang28 于 2013-11-21 20:30 编辑

本贴为【VBA字典数组201301班】D组第三讲作业 上交专用，其它学员勿入

1.要求使用字典完成
2.所有的代码均写在按钮指定的过程中
3.要求代码缩进
4.要求有注释（关键代码处）
5.要求强制声明
3-5要求一共占6分，每点2分，6道题最多扣6分
作业上截止时间：2013年11月20日 18：00，原则上在未评分和开贴前上交作业均视为有效

fffox · 发表于 2013-11-16 17:02

本帖最后由 fffox 于 2013-11-16 17:22 编辑

先交了
奇怪，以前上交代码都有缩进的，这次怎么就没了？
只能再传个附件了

Option Explicit
'字典采用前期绑定
Sub 求不重复值1()
Dim arr, i As Integer, d1 As New Dictionary
arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
For i = 1 To UBound(arr)
d1.Item(arr(i, 1)) = ""
'通过循环，把A列值存入字典Key里，利用字典Key不重复特征，取得不重复值
Next
Range("c2").Resize(d1.Count) = Application.Transpose(d1.Keys)
'字典Kesy是一维数组，通过转置把Keys写入目标区域
End Sub
Sub 求不重复值2()
Dim arr, i As Integer, d2 As New Dictionary
arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
d2.CompareMode = 1 '设置字典不区分大小写
For i = 1 To UBound(arr)
d2(arr(i, 1)) = ""
Next
'写入目标区域，用Resize(d2.Count)自动扩展目标区域大小
Range("d2").Resize(d2.Count) = Application.Transpose(d2.Keys)
End Sub
Sub 双向求值()
Dim d3 As New Dictionary
Dim i As Byte
Dim arr
arr = Range("a2:b" & Range("b65536").End(xlUp).Row)
For i = 1 To UBound(arr, 1)
d3.Item(arr(i, 1)) = arr(i, 2)
d3.Item(arr(i, 2)) = arr(i, 1)
'通过循环，分别以城市分Key简写为Item，和简写为Key城市为Item存入字典
Next
MsgBox d3.Item(Range("d3").Value) '以d3值为Key查找对应的Item
End Sub
Sub 多条件查找()
Dim d5a As New Dictionary, d5b As New Dictionary
Dim arr, brr, str$, i As Byte
arr = Range("a2:d5")
For i = 1 To UBound(arr)
str = arr(i, 1) & arr(i, 2) '以产品&规格为关键字创建字典
d5a(str) = arr(i, 3) '创建d5a字典，item为数量
d5b(str) = arr(i, 4) '创建d5b字典，item为单价
Next
For i = 12 To 13 '根据单元格内容取值后分别写入目标单元格
str = Cells(i, 1) & Cells(i, 2)
Cells(i, 3) = d5a(str)
Cells(i, 4) = d5b(str)
Next
' brr = Range("a12:d13") '结果存入数组后一次性写入
' For i = 1 To UBound(brr)
' str = brr(i, 1) & brr(i, 2)
' brr(i, 3) = d5a(str)
' brr(i, 4) = d5b(str)
' Next
' Range("a12").Resize(UBound(brr), 4) = brr
End Sub
Sub 单条件求和()
Dim d4 As New Dictionary
Dim arr, i%
arr = Range("b2:c" & Range("c65536").End(3).Row)
For i = 1 To UBound(arr)
d4(arr(i, 1)) = d4(arr(i, 1)) + arr(i, 2)
'以产品为Key，以数量为Item，通过循环，分别计算Item之和
Next
Range("e2").Resize(d4.Count) = Application.Transpose(d4.Keys)
Range("f2").Resize(d4.Count) = Application.Transpose(d4.Items)
End Sub
Sub 多列求和()
Dim d As New Dictionary
Dim arr, brr()
Dim i As Byte, iRow As Byte, k As Byte, j As Byte
arr = [a2:d6]
For i = 1 To UBound(arr)
If Not d.Exists(arr(i, 1)) Then '当产品在字典中不存在时
k = k + 1 '需要在数组中新增一行
ReDim Preserve brr(1 To 4, 1 To k) '动态扩展数组brr
d(arr(i, 1)) = k '字典中保存对应的行数
For j = 1 To 4
brr(j, k) = arr(i, j) '行列转换存入相应数据
Next
Else
iRow = d(arr(i, 1)) '产品在字典中存在，取得行数
brr(2, iRow) = brr(2, iRow) + arr(i, 2)
brr(3, iRow) = arr(i, 3) '取最新单价
brr(4, iRow) = brr(4, iRow) + arr(i, 4)
End If
Next
Range("a13").Resize(k, 4) = Application.Transpose(brr)
End Sub
Sub 多条件求和()
Dim d As New Dictionary
Dim arr, i As Byte, iRow As Byte, str As String
Dim k As Byte, brr(1 To 10, 1 To 3) '事先声明足够大的目标数组
arr = [a2:c6]
For i = 1 To UBound(arr)
str = arr(i, 1) & arr(i, 2) '以产品&规格为关键字
If Not d.Exists(str) Then '关键字在字典中不存在，直接赋值
k = k + 1
d(str) = k
brr(k, 1) = arr(i, 1)
brr(k, 2) = arr(i, 2)
brr(k, 3) = arr(i, 3)
Else '字典中存在，对应行中数量相加
iRow = d(str)
brr(iRow, 3) = brr(iRow, 3) + arr(i, 3)
End If
Next
Range("a11").Resize(k, 3) = brr
End Sub

复制代码

培训部招生办 · 发表于 2013-11-16 23:30

D004-风林火山

一杯清荼 · 发表于 2013-11-17 09:11

本帖最后由一杯清荼于 2013-11-19 16:52 编辑

题1:

Sub 求不重复值1()
'思路:利用KEY值的唯一性去重
Dim arr, brr, i As Integer, d As Object
Set d = CreateObject("Scripting.Dictionary")
arr = sheets("求不重复值").[a1].CurrentRegion
For i = 1 To UBound(arr)
d(arr(i, 1)) = ""
Next
sheets("求不重复值").[c2].Resize(d.Count, 1) = Application.Transpose(d.Keys)
End Sub
Sub 求不重复值2()
Dim arr, brr, i As Integer, d As Object
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare '不区分大小写
arr =sheets("求不重复值"). [a1].CurrentRegion
For i = 1 To UBound(arr)
d(arr(i, 1)) = ""
' d(UCase(arr(i, 1))) = ""
Next
sheets("求不重复值").[d2].Resize(d.Count, 1) = Application.Transpose(d.Keys)
End Sub

复制代码

题2：

Sub 双向求值()
Dim arr, i As Integer, d As Dictionary, d2 As Dictionary
arr = Sheets("双向查找").[a1].CurrentRegion
Set d = New Dictionary
Set d2 = New Dictionary
For i = 2 To UBound(arr)
d(arr(i, 1)) = arr(i, 2) '将城市写入字典d
d2(arr(i, 2)) = arr(i, 1) '将简写写入字典d1
Next
With Sheets("双向查找").Range("d3")
If d(.Value) = "" Then '查找值不在d字典中时
MsgBox d2(.Value) '就到d2字典中找
Else
MsgBox d(.Value)
End If
End With
End Sub

复制代码

题3：

Sub 单条件求和()
Dim arr, i As Integer, d As Object
Set d = CreateObject("Scripting.Dictionary")
arr =sheets("单条件求和"). [a1].CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 2)) = d(arr(i, 2)) + arr(i, 3) '相同KEY值的项相加
Next
sheets("单条件求和").[e2].Resize(d.Count, 2) = Application.Transpose(Array(d.Keys, d.Items))
End Sub

复制代码

Sub 多条件查找()
'主要思路:将查找的条件相连接后作为字典的KEY，要查找的内容相连接后作为字典的项，写出入字典中,
'最后按连接的字符分列
Application.DisplayAlerts = False
Dim d As Dictionary
Set d = New Dictionary
Dim i As Integer, j As Integer, arr, brr, crr(1 To 2)
arr = [a1].CurrentRegion
brr = [a11].CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 1) & arr(i, 2)) = arr(i, 3) & ";" & arr(i, 4)
Next
For j = 2 To UBound(brr)
If d.Item(brr(j, 1) & brr(j, 2)) <> "" Then
crr(j - 1) = d.Item(brr(j, 1) & brr(j, 2))
Else
crr(j - 1) = "" & ";" & ""
End If
Next
[c12].Resize(2, 1) = Application.Transpose(crr)
Range("c12").Resize(2).TextToColumns Other:=True, OtherChar:=";"
Application.DisplayAlerts = True
End Su
题5：
Sub 多列求和()
'主要思路：用字典做标记,当有重复时，通过这个标记来改变数组中与之对应的值.
Dim arr, brr(), i As Integer, j As Integer, n As Byte, d As Object
Set d = CreateObject("Scripting.Dictionary")
arr = sheets("多列求和").[a1].CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 3)
For i = 2 To UBound(arr)
If Not d.Exists(arr(i, 1)) Then
d(arr(i, 1)) = d.Count + 1
brr(d.Count, 1) = arr(i, 2)
brr(d.Count, 2) = arr(i, 3)
brr(d.Count, 3) = arr(i, 4)
Else
n = d(arr(i, 1))
brr(n, 1) = arr(i, 2) + brr(n, 1)
brr(n, 2) = arr(i, 3)
brr(n, 3) = arr(i, 4) + brr(n, 3)
End I
Next
sheets("多列求和").[a13].Resize(d.Count) = Application.Transpose(d.Keys)
sheets("多列求和").[b13].Resize(d.Count, 3) = brr
End Sub

复制代码

题6:

Sub 多条件求和()
Application.DisplayAlerts = False
Dim i As Integer, d As Object, arr
Set d = CreateObject("Scripting.Dictionary")
arr =sheets("多条件求和"). [a1].CurrentRegion
For i = 2 To UBound(arr)
If d.Exists(d(arr(i, 1) & ";" & arr(i, 2))) Then
d(arr(i, 1) & ";" & arr(i, 2)) = arr(i, 3)
Else
d(arr(i, 1) & ";" & arr(i, 2)) = d(arr(i, 1) & ";" & arr(i, 2)) + arr(i, 3) '相同的产品累加
End If
Next
sheets("多条件求和"). [a11].Resize(4) = Application.Transpose(d.Keys)
sheets("多条件求和").[c11].Resize(4) = Application.Transpose(d.Items)
sheets("多条件求和").Range("a11").Resize(4).TextToColumns Other:=True, OtherChar:=";" '分列
Application.DisplayAlerts = True
End Sub

复制代码

w2001pf · 发表于 2013-11-18 15:44

D05:w2001pf
Option Explicit

Sub 求不重复值1()
   Dim arr, i, rowend
Dim d As New Dictionary '声明一个字典
With Sheet2
      rowend = .Range("A" & Rows.Count).End(xlUp).Row
      arr = .Range("A1:A" & rowend)
      For i = 1 To UBound(arr) '
         If d.Exists(arr(i, 1)) = False Then d(arr(i, 1)) = "" '如果关键字不存在就定义它的项为空
      Next i
      .Range("D2").Resize(d.Count) = Application.Transpose(d.Keys) '通过转置函数把字典的关键字读入到指定的位置
End With
End Sub

Sub 求不重复值2()
Dim arr, i, rowend
Dim d As New Dictionary '声明一个字典
With Sheet2
      rowend = .Range("A" & Rows.Count).End(xlUp).Row
      arr = .Range("A1:A" & rowend)
      d.CompareMode = vbTextCompare '声明不区分大小写
      For i = 1 To UBound(arr) '
         If d.Exists(arr(i, 1)) = False Then d(arr(i, 1)) = "" '如果关键字不存在就定义它的项为空
      Next i
      .Range("D2").Resize(d.Count) = Application.Transpose(d.Keys) '通过转置函数把字典的关键字读入到指定的位置
End With
End Sub

Sub 双向求值()
Dim arr, i, rowend, caz, jgz
Dim d As New Dictionary '声明一个字典
With Sheet9
      caz = .Range("D3").Text '用变量caz表示要查找的值
      rowend = .Range("A" & Rows.Count).End(xlUp).Row
      arr = .Range("A1:B" & rowend)
      For i = 1 To UBound(arr)
         If d.Exists(arr(i, 1)) = False Then d(arr(i, 1)) = arr(i, 2) '如果关键字不存在就定义它的项为对应的B列的值
      Next i
      For i = 0 To d.Count - 1 '在字典中循环查找需要查找的值
         If d.Keys(i) = caz Then '如果关键字中没有找到就到对应的项中查找
            jgz = d.Items(i)
         ElseIf d.Items(i) = caz Then
            jgz = d.Keys(i)
         End If
      Next i
End With
MsgBox prompt:=caz & String(2, vbCrLf) & "查找结果是" & jgz, Title:="这是你要的结果吗？"

End Sub

Sub 多条件查找()

Dim arr, i, rowend, caz, j
Dim d As New Dictionary '声明一个字典
With Sheet8
      .Range("C12:D13") = ""
      caz = .Range("A12:D13") '定义一个数组，装入查找的结果
      rowend = .Range("A1").End(xlDown).Row
      arr = .Range("A2:D" & rowend)
      For i = 1 To UBound(arr)
         d(arr(i, 1) & arr(i, 2)) = arr(i, 3) & "|" & arr(i, 4)  '如果关键字（两个条件）不存在就定义它的项为对应的两列的值
      Next i
      For j = 1 To UBound(caz)
         For i = 0 To d.Count - 1 '在字典中循环查找需要查找的值
            If d.Keys(i) = caz(j, 1) & caz(j, 2) Then '在关键字中查找
                  caz(j, 3) = Split(d.Items(i), "|")(0) '将关键字对应的项分列为两列装入查找的结果中
                  caz(j, 4) = Split(d.Items(i), "|")(1)

            End If
         Next i
      Next j
      .Range("A12").Resize(UBound(caz), UBound(caz, 2)) = caz
End With
End Sub

Sub 单条件求和()
Dim arr, i, rowend
Dim d As New Dictionary '声明一个字典
With Sheet10
      rowend = .Range("A" & Rows.Count).End(xlUp).Row
      arr = .Range("B2:C" & rowend)
      For i = 1 To UBound(arr) '
         d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2) '关键字的项值累加
      Next i
      .Range("E2").Resize(d.Count) = Application.Transpose(d.Keys) '通过转置函数把字典的关键字与项读入到指定的位置
      .Range("F2").Resize(d.Count) = Application.Transpose(d.Items)
End With
End Sub

Sub 多列求和()
Dim d As New Dictionary '声明一个字典
Dim i As Long
Dim j As Long
Dim arrlx, arr, rowend
With Sheet12
      arrlx = Range("B1:D1") '定义一个列项目的数组（数量，单价，金额）
      rowend = .Range("A1").End(xlDown).Row
      arr = .Range("A2:D" & rowend)
      For j = 1 To UBound(arrlx, 2)
         d(arrlx(1, j)) = ""
         Set d(arrlx(1, j)) = New Dictionary '声明关键字（列项目的数组（数量，单价，金额））的项为字典，即字典套字典
      Next j
      For i = 1 To UBound(arr)
         For j = 1 To UBound(arrlx, 2)
            If j <> 2 Then
                  d(arrlx(1, j))(arr(i, 1)) = d(arrlx(1, j))(arr(i, 1)) + arr(i, j + 1) '关键字（如A的数量，金额等）的项值累加
            ElseIf j = 2 Then d(arrlx(1, j))(arr(i, 1)) = arr(i, j + 1) '关键字是单价的对应项值就是它本身，因为单价不累加的
            End If
         Next j
      Next i
      .Range("A13").Resize(d("数量").Count, 1) = Application.WorksheetFunction.Transpose(d("数量").Keys) '把数量（字典）的关键字装入到结果中
      For j = 1 To UBound(arrlx, 2)
         Range("B13").Offset(0, j - 1).Resize(d("数量").Count, 1) = Application.WorksheetFunction.Transpose(d(arrlx(1, j)).Items) '把对应的求和结果装入到指定的位置
      Next j
End With
End Sub

Sub 多条件求和()
Dim arr, i, rowend, caz, j
Dim d As New Dictionary '声明一个字典
With Sheet13
      .Range("A11:D14") = ""
      rowend = .Range("A1").End(xlDown).Row
      arr = .Range("A2:C" & rowend)
      For i = 1 To UBound(arr)
         d(arr(i, 1) & "|" & arr(i, 2)) = d(arr(i, 1) & "|" & arr(i, 2)) + arr(i, 3) '关键字（两列）的项值累加
      Next i
      ReDim caz(1 To d.Count, 1 To 3) '定义一个数组，装入查找的结果

      For i = 0 To d.Count - 1 '在字典中循环，把求和结果装入到查找的结果数组中
         caz(i + 1, 1) = Split(d.Keys(i), "|")(0) '将关键字分列为两列装入查找的结果中
         caz(i + 1, 2) = Split(d.Keys(i), "|")(1)
         caz(i + 1, 3) = d.Items(i)

      Next i

      .Range("A11").Resize(UBound(caz), UBound(caz, 2)) = caz
End With
End Sub

ly258 · 发表于 2013-11-18 17:15

本帖最后由 ly258 于 2013-11-19 15:49 编辑

请多多点评，谢谢！

Option Explicit
Sub 求不重复值1()
Dim x, arr
Dim d As New Dictionary
d.CompareMode = 0 '设置比较模式
For Each x In Range("a1:a12").Value '遍历读取数据
If Not d.Exists(x) Then '判断是否重复
d.Add x, ""
End If
Next x
Range("c2").Resize(d.Count, 1) = Application.Transpose(d.Keys) '一次性写入对应区域
End Sub
Sub 求不重复值2()
Dim x, arr
Dim d As New Dictionary
d.CompareMode = 1 '设置比较模式
For Each x In Range("a1:a12").Value '遍历读取数据
If Not d.Exists(x) Then '判断是否重复
d.Add x, ""
End If
Next x
Range("d2").Resize(d.Count, 1) = Application.Transpose(d.Keys) '一次性写入对应区域
End Sub
Sub 双向求值()
Dim x, arr
Dim d As New Dictionary
Dim dd As New Dictionary
d.CompareMode = 0 '设置比较模式
arr = Range("a2:b6 ")
For x = 1 To UBound(arr) '循环读取数据，放到字典d中
d.Add arr(x, 1), arr(x, 2)
dd.Add arr(x, 2), arr(x, 1)
Next x
x = Range("d3").Value
If d.Exists(x) Then '判断单元格中的数据是否在字典中存在
MsgBox d.Item(x)
Else
MsgBox dd.Item(x)
End If
End Sub
Sub 多条件查找()
Dim d As New Dictionary
Dim arr, h, i, arr1, arr2
arr = Range("a2:d5")
arr1 = Range("a12:d13")
For i = 1 To UBound(arr)
d.Add arr(i, 1) & arr(i, 2), arr(i, 3) & "*" & arr(i, 4) '以组合的方式放入字典
Next i
For i = 1 To UBound(arr1)
h = arr1(i, 1) & arr1(i, 2) '把设置的条件进行组合
If d.Exists(h) Then '在字典中查找组合条件
arr2 = Split(d.Item(h), "*") '找到组合条件后以*号进行分割，生成数组
Else
arr2 = Array("", "")
End If
arr1(i, 3) = arr2(0) '生成的数组写入对应数组
arr1(i, 4) = arr2(1)
Next i
Range("a12:d13") = arr1 '一次性写入到对应区域
End Sub
Sub 单条件求和()
Dim d As New Dictionary
Dim arr, h
arr = Range("b2:c5")
For h = 1 To UBound(arr)
If d.Exists(arr(h, 1)) Then '判断新读入的数据是否在字典中存在
d(arr(h, 1)) = d(arr(h, 1)) + arr(h, 2) '累计求和
Else
d.Add arr(h, 1), arr(h, 2) '新增字典中没有KEY
End If
Next h
Range("e2").Resize(d.Count, 1) = Application.Transpose(d.Keys)
Range("f2").Resize(d.Count, 1) = Application.Transpose(d.Items)
End Sub
Sub 多列求和()
Dim d As New Dictionary
Dim arr, h, arr1(1 To 10, 1 To 3), t, s
arr = Range("a2:d6")
s = 1
For h = 1 To UBound(arr)
If d.Exists(arr(h, 1)) Then
t = d.Item(arr(h, 1))
arr1(t, 1) = arr1(t, 1) + arr(h, 2) '计算对应数值
arr1(t, 3) = arr1(t, 3) + arr(h, 4)
If arr(h, 3) > arr1(t, 2) Then '单价统计最大值
arr1(t, 2) = arr(h, 3)
End If
Else
d.Add arr(h, 1), s '数组中新增未找到的产品，并用item作为标记
s = s + 1 '标记记数据器加1
h = h - 1 '改变循环变量，让新增的产品参加统计
End If
Next h
Range("a13").Resize(d.Count, 1) = Application.Transpose(d.Keys) '写入到对应区域
Range("b13").Resize(UBound(arr1, 1), UBound(arr1, 2)) = arr1 '写入到对应区域
End Sub
Sub 多条件求和()
Dim d As New Dictionary
Dim arr, h, s, arr1, arr2, arr3
arr = Range("a2:c6")
For h = 1 To UBound(arr) '以“产品*规格”组合的形式建立字典，并在Item中求和
s = arr(h, 1) & "*" & arr(h, 2)
If d.Exists(s) Then
d.Item(s) = d.Item(s) + arr(h, 3)
Else
d.Add s, arr(h, 3)
End If
Next h
ReDim arr(1 To d.Count, 1 To 3)
arr1 = d.Items '把字典中的KEY,ITEM存到数组
arr2 = d.Keys
For h = 1 To d.Count
arr(h, 3) = arr1(h - 1)
arr3 = Split(arr2(h - 1), "*") '用*号把字典中的KEY进行分割
arr(h, 1) = arr3(0)
arr(h, 2) = arr3(1)
Next h
Range("a11").Resize(UBound(arr, 1), UBound(arr, 2)) = arr '写入到对应区域
End Sub

复制代码

阿呆88 · 发表于 2013-11-19 13:12

本帖最后由阿呆88 于 2013-11-19 13:21 编辑

Sub 多条件求和()

Application.DisplayAlerts = False

Dim i As Integer, d As Object, arr

Set d = CreateObject("Scripting.Dictionary")

arr = [a1].CurrentRegion

For i = 2 To UBound(arr)

If d.Exists(d(arr(i, 1) & ";" & arr(i, 2))) Then

d(arr(i, 1) & ";" & arr(i, 2)) = arr(i, 3)

Else

d(arr(i, 1) & ";" & arr(i, 2)) = d(arr(i, 1) & ";" & arr(i, 2)) + arr(i, 3)

End If

Next

[a11].Resize(4) = Application.Transpose(d.Keys)

[c11].Resize(4) = Application.Transpose(d.Items)

Range("a11").Resize(4).TextToColumns Other:=True, OtherChar:=";" '分列

Application.DisplayAlerts = True

End Sub

Sub 单条件求和()

Dim arr, i As Integer, d As Object

Set d = CreateObject("Scripting.Dictionary")

arr = [a1].CurrentRegion

For i = 2 To UBound(arr)

If Not d.Exists(arr(i, 2)) Then

d(arr(i, 2)) = d(arr(i, 2))

End If

d(arr(i, 2)) = d(arr(i, 2)) + arr(i, 3)

Next

[e2].Resize(d.Count, 2) = Application.Transpose(Array(d.Keys, d.Items))

End Sub

其他不会
复制代码

xhrys · 发表于 2013-11-20 15:10

自己只做了几题目，后面几道题目完全是代码校长的棋盘法的

联乔 · 发表于 2013-11-20 16:36

时间来不及了没有解释

【VBA字典数组201301班】第三讲作业 D07 联乔.rar (51.46 KB, 下载次数: 12)

水上漂123 · 发表于 2013-11-20 17:57

Sub 求不重复值1()
Dim d
Dim arr, k
Dim i As Byte
Set d = CreateObject("scripting.dictionary")
d.comparemode = 0
arr = Range("a1:a12")
For i = 1 To UBound(arr)
d(arr(i, 1)) = ""
Next i
k = d.keys
Range("c2").Resize(d.Count, 1) = Application.Transpose(k)
Set d = Nothing
End Sub
Sub 求不重复值2()
Dim d
Dim arr, k
Dim i As Byte
Set d = CreateObject("scripting.dictionary")
d.comparemode = 1
arr = Range("a1:a12")
For i = 1 To UBound(arr)
d(arr(i, 1)) = ""
Next i
k = d.keys
Range("d2").Resize(d.Count, 1) = Application.Transpose(k)
Set d = Nothing
End Sub

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

[习题] 【VBA字典数组201301班】D组- 第三讲作业上交处

相关帖子

点评

评分

评分

评分

评分

评分

点评

评分

点评

评分

点评

评分

评分