【VBA字典数组201301班】C 组 第四讲作业上交贴

无聊的疯子

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

作业要求：
1.要求使用字典完成
2.所有的代码均写在按钮指定的过程中（过程名称以作业题名称方式命名）
3.要求代码缩进
4.要求有注释（关键代码处）
5.要求强制声明

3-5要求一共占6分，每点2分，6道题最多扣6分

作业上交：
1.直接上交代码即可
2.上交时间：2013-11-27  20：00（原则上未评作业或未开贴前上交即视为在有效内）
3.上交代码时请使用添加代码文字的方式上交
4.代码不要分过程添加，直接一次添加，方便复制

添加代码文字的方法：
[code]     
这里放代码
[=/code]

使用时，请不要输入 / 前面的 =

雪舞子

c06:雪舞子

1. Sub 作业一()
   
2.     Dim dic As Object, arr, brr(), crr()                                 '定义变量,arr源数组/brr结果数组/crr源数据1~8列数组
   
3.     Dim i%, j%, m%, n%, cr$, ma$, sth
   
4.    
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     arr = Sheets("源数据一").[a1].CurrentRegion                          '源数据送进arr
   
7.     ReDim crr(1 To UBound(arr))                                          '重新定义过渡数组
   
8.    
   
9.         For i = 1 To UBound(arr)
   
10.             For j = 1 To 8
    
11.                 crr(i) = crr(i) & "-" & arr(i, j)                        '源数据1~8列建立一列多行数组,也是字典唯一值标准
    
12.             Next
    
13.         
    
14.             If dic.exists(crr(i)) Then                                   '如果字典存在此key值
    
15.             
    
16.                 m = dic(crr(i))                                          '取出item值,即行数
    
17.                 brr(10, m) = brr(10, m) + arr(i, 10)                     '"不良数量"累加
    
18.                 brr(9, m) = brr(9, m) & " " & arr(i, 9)                  '"不良位置"累计
    
19.                 brr(12, m) = arr(i, 12)                                  '标注"产量"
    
20.             
    
21.             Else                                                          '无此key值
    
22.             
    
23.                 n = n + 1                                                 '条目累加
    
24.                 dic(crr(i)) = n                                           '存入条目
    
25.                 ReDim Preserve brr(1 To UBound(arr, 2), 1 To n)           '定义结果数组
    
26.                
    
27.                 For j = 1 To UBound(arr, 2) - 1
    
28.                     brr(j, n) = arr(i, j)                                 '除最后一列将源值摆放到结果数组
    
29.                 Next
    
30.                     
    
31.             
    
32.             End If
    
33.         
    
34.         Next
    
35.         brr(12, 1) = arr(1, 12)                                            '补充最后标题单元格
    
36.         
    
37.     ma = "第一题答案-" & Format(Time(), "hhmm")                            '建立工作表名
    
38.     For Each sth In Sheets
    
39.         If sth.Name Like "第一题答案*" Then GoTo 100                       '工作表中存在"答案"工作表直接将其改名
    
40.     Next
    
41.     Set sth = Sheets.Add
    
42.         sth.Move after:=Sheets("效果一")                                   '不存在"答案"工作表则创建新工作表
    
43. 100:
    
44.         sth.Name = ma
    
45.     Sheets(ma).[a1].CurrentRegion.ClearContents
    
46.     Sheets(ma).[a1].Resize(n, UBound(arr, 2)) = Application.Transpose(brr) '输出结果并更改工作名为运行时间
    
47.     Sheets(ma).Activate
    
48. 
    
49. End Sub
    
50. 
    
51. 
    
52. Sub 作业二()
    
53. Dim dic As Object, arr1, arr2(), brr1, brr2(), crr(), i&, j%, n&
    
54. Set dic = CreateObject("scripting.dictionary")
    
55. 
    
56. arr1 = Sheets("作业二").Range("a2", Cells(Rows.Count, "f").End(xlUp))    'A数组
    
57. brr1 = Sheets("作业二").Range("h2", Cells(Rows.Count, "m").End(xlUp))    'B数组
    
58. ReDim arr2(1 To UBound(arr1))                                            'A数组行连接过渡数组
    
59. ReDim brr2(1 To UBound(brr1))                                            'B数组行连接过渡数组
    
60.     For i = 1 To UBound(arr1)
    
61.         For j = 1 To 6
    
62.             arr2(i) = arr2(i) & "-" & arr1(i, j)                         'A数组行连接成一个字符串形成新的数组
    
63.         Next
    
64.         dic(arr2(i)) = ""                                                '加入字典并过滤唯一性
    
65.     Next
    
66.     For i = 1 To UBound(brr1)
    
67.         For j = 1 To 6
    
68.             brr2(i) = brr2(i) & "-" & brr1(i, j)                          'B数组行连接成一个字符串形成新的数组
    
69.         Next
    
70.         
    
71.         If dic.exists(brr2(i)) Then                                       '此行去字典比较有否相同行
    
72.             n = n + 1
    
73.             ReDim Preserve crr(1 To 6, 1 To n)                            '有结果数组增加一行
    
74.             For j = 1 To 6
    
75.                 crr(j, n) = brr1(i, j)                                    '并将B数组相应行列装进结果数组
    
76.             Next
    
77.         End If
    
78.         
    
79.     Next
    
80. 
    
81. 
    
82. Sheets("作业二").[o2].CurrentRegion.ClearContents
    
83. Sheets("作业二").[o2].Resize(n, 6) = Application.Transpose(crr)            '输出结果
    
84. 
    
85. End Sub
    
86. 
    
87. Sub 作业三()
    
88. Dim dic As Object, arr1, arr2(), brr(), i&, j%, n&, m&
    
89. Set dic = CreateObject("scripting.dictionary")
    
90. 
    
91. arr1 = Sheets("作业三").Range("a2", Cells(Rows.Count, "c").End(xlUp))  '源数据装数组arr1
    
92. ReDim arr2(1 To UBound(arr1))                                          '定义源数据过渡数组
    
93.     For i = 1 To UBound(arr1)
    
94.         If arr1(i, 1) = "湖北" Then                                     '只对"湖北"操作
    
95.         m = m + 1                                                       '"湖北"行累加
    
96.             For j = 1 To 3
    
97.                arr2(m) = arr2(m) & "-" & arr1(i, j)                     '行连接进数组arr2
    
98.             Next
    
99.         
    
100.         If Not dic.exists(arr2(m)) Then                                 '字典中没有该行则
     
101.             n = n + 1                                                   '累加
     
102.             ReDim Preserve brr(1 To 3, 1 To n)                          '结果数组增加重定义
     
103.             For j = 1 To 3
     
104.                 brr(j, n) = arr1(i, j)                                  '源数据的相应数据进结果数组
     
105.             Next
     
106.         End If
     
107.         dic(arr2(m)) = ""                                                '装字典
     
108.         End If
     
109.     Next
     
110.    
     
111. Sheets("作业三").[e2.g12].ClearContents
     
112. Sheets("作业三").[e2].Resize(n, 3) = Application.Transpose(brr)          '输出结果
     
113. 
     
114. Application.DeleteCustomList Application.CustomListCount                                        '自定义排序
     
115. Application.AddCustomList ListArray:=Array("武汉", "襄阳", "荆州")                              '排序关键字
     
116. Range("e1:g10").Sort key1:=[f1], Header:=xlYes, ordercustom:=Application.CustomListCount + 1
     
117.     'Range("e1:g10")区域,以关键字在F列去首行排序
     
118. 
     
119. End Sub
     
120. 
     

复制代码

xdragon

1. Sub 作业三()
   
2.   Dim arr(), i As Integer, brr(), cnt As Integer
   
3.   arr = Range("A2:C" & Cells(Rows.Count, 1).End(xlUp).Row).Value
   
4.   With CreateObject("scripting.dictionary")
   
5.   For i = 1 To UBound(arr) '将A列中是湖北的行数据合并放入字典key
   
6.     If arr(i, 1) = "湖北" Then
   
7.       If Not .exists(arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)) Then
   
8.         cnt = cnt + 1
   
9.         .Item(arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)) = cnt '将每个key标记从1开始的索引号
   
10.         ReDim Preserve brr(1 To 3, 1 To cnt) '根据索引号扩大brr数组，存放新的key索引号对应的arr中的值
    
11.         brr(1, cnt) = arr(i, 1)
    
12.         brr(2, cnt) = arr(i, 2)
    
13.         brr(3, cnt) = arr(i, 3)
    
14.       End If
    
15.     End If
    
16.   Next
    
17.   End With
    
18.   Range("E2:G" & Cells(Rows.Count, "E").End(xlUp).Row).ClearContents
    
19.   Range("E2").Resize(UBound(brr, 2), UBound(brr)) = Application.Transpose(brr)
    
20. End Sub
    
21. 
    
22. 
    
23. Sub 作业二()
    
24.   Dim arr(), brr(), crr(), i&, j As Byte, cnt&, s$, t
    
25.   t = Timer
    
26.   arr = Range("A2:F" & Cells(Rows.Count, "A").End(xlUp).Row).Value
    
27.   With CreateObject("scripting.dictionary")
    
28.     For i = 1 To UBound(arr) '将行数据合并后存入字典key
    
29.       s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 5) & "|" & arr(i, 6)
    
30.       If Not .exists(s) Then .Item(s) = ""
    
31.     Next
    
32.     brr = Range("H2:M" & Cells(Rows.Count, "H").End(xlUp).Row).Value
    
33.     ReDim crr(1 To IIf(UBound(arr) > UBound(brr), UBound(arr), UBound(brr)), 1 To 6) '定义存放结果的数据大小为arr和brr上限的最大值
    
34.     Erase arr
    
35.     For i = 1 To UBound(brr)
    
36.       s = brr(i, 1) & "|" & brr(i, 2) & "|" & brr(i, 3) & "|" & brr(i, 4) & "|" & brr(i, 5) & "|" & brr(i, 6)
    
37.       If .exists(s) Then '将brr中整行的数据合并后在字典中查找，如果存在，则将对应的brr整行数据存入crr数组
    
38.         cnt = cnt + 1
    
39.         For j = 1 To 6
    
40.           crr(cnt, j) = brr(i, j)
    
41.         Next
    
42.       End If
    
43.     Next
    
44.   End With
    
45.   Range("O2:T" & Cells(Rows.Count, "O").End(xlUp).Row).ClearContents
    
46.   Range("O2").Resize(cnt, 6) = crr '导出结果到单元格
    
47.   MsgBox "完成计算，共使用 " & Timer - t & " 秒"
    
48. End Sub
    
49. 
    
50. 
    
51. Sub 作业一()
    
52.   Application.ScreenUpdating = False
    
53.   Dim arr(), brr(), d As Object, i&, j As Byte, str$, cnt&
    
54.   
    
55.   i = Sheets("源数据一").Cells(Rows.Count, 1).End(xlUp).Row
    
56.   arr = Sheets("源数据一").Range("A2:L" & i).Value
    
57.   Set d = CreateObject("scripting.dictionary")
    
58.   
    
59.   For i = 1 To UBound(arr)
    
60.     str = ""
    
61.     For j = 1 To 8
    
62.       str = str & "|" & arr(i, j) '将每行1-8列数据合并
    
63.     Next
    
64.    
    
65.     If Not d.exists(str) Then '字典中如果不存在这个合并值则添加此key，并添加索引值
    
66.       cnt = cnt + 1
    
67.       d(str) = cnt
    
68.       ReDim Preserve brr(1 To 12, 1 To cnt)
    
69.       brr(9, cnt) = arr(i, 9)
    
70.       If arr(i, 8) = "假焊" Then brr(12, cnt) = arr(i, 12) '若出现假焊的，取此行产量的值
    
71.     Else
    
72.       brr(9, d(str)) = brr(9, d(str)) & " " & arr(i, 9) '将第九列数字连接
    
73.     End If
    
74.     For j = 1 To 8
    
75.       brr(j, d(str)) = arr(i, j)
    
76.     Next
    
77.     brr(10, d(str)) = brr(10, d(str)) + arr(i, 10)
    
78.     brr(11, d(str)) = arr(i, 11)
    
79.     'brr(12, d(str)) = brr(12, d(str)) + arr(i, 12)  '汇总项
    
80.   Next
    
81.   
    
82.   On Error GoTo MsgAlert '如果遇到同一时间导出报表的，提示错误
    
83.   Worksheets.Add '
    
84.   ActiveSheet.Name = "第一题答案-" & Format(Time, "hhmm") '添加新的工作表并修改工作表名
    
85.   Range("A2").Resize(cnt, 12) = Application.Transpose(brr) '导出数据区域到单元格
    
86.   arr = Sheets("源数据一").Range("A1:L1").Value
    
87.   Range("A1:L1") = arr
    
88.   
    
89.   With Range("A1").CurrentRegion '设置导出区域的字体，列宽，边框及标题行背景颜色
    
90.     .Columns.AutoFit
    
91.     .Font.Size = 9
    
92.     .Borders.LineStyle = 1
    
93.     .Resize(1, 12).Interior.Color = vbCyan
    
94.   End With
    
95.   Application.ScreenUpdating = True
    
96.   Exit Sub
    
97.   
    
98. MsgAlert: '提示错误
    
99.   Application.DisplayAlerts = False
    
100.   ActiveSheet.Delete
     
101.   MsgBox "您的计算过于频繁，请于1分钟后再次尝试", vbInformation + vbOKOnly, "提示"
     
102.   Application.DisplayAlerts = True
     
103.   Application.ScreenUpdating = True
     
104. End Sub

复制代码

三级下拉菜单。。。

1. Option Explicit
   
2. 
   
3. Private Sub Worksheet_Change(ByVal Target As Range)
   
4.     If Target.Column = 5 Then Target(1).Offset(0, 1).Resize(1, 2) = "" '如果E列的值更改，则清空对应的F和G列的值
   
5.     If Target.Column = 6 Then Target(1).Offset(0, 1) = "" '如果F列的值更改，则清空对应G列的值
   
6. End Sub
   
7. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
8.     Dim Dic, cell As Range, rngs As Range
   
9.     On Error Resume Next
   
10.     Set Dic = CreateObject("Scripting.Dictionary")
    
11.     Set rngs = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    
12.     Select Case Target(1).Column
    
13.     Case 5 '在E列添加数据有效性，把A列存入字典key，然后在数据有效性序列中根据keys生成序列
    
14.         For Each cell In rngs
    
15.             Dic(cell.Text) = ""
    
16.         Next cell
    
17.         With Target(1).Validation '设置数据有效性
    
18.             .Delete '删除目标单元格原数据有效性
    
19.             .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(Dic.keys, ",") '添加序列，将keys合并，以“，”分隔
    
20.             .InCellDropdown = True '有下拉菜单
    
21.         End With
    
22.     Case 6 '在F列添加数据有效性，把目标单元格所在行的E列单元格与A列中的值比较，若一致，则将其A列中对应的B列的值存入字典key
    
23.         For Each cell In rngs
    
24.             If cell = Target(1).Offset(0, -1) Then
    
25.                 Dic(cell.Offset(0, 1).Text) = ""
    
26.             End If
    
27.         Next cell
    
28.         With Target(1).Validation
    
29.             .Delete
    
30.             .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(Dic.keys, ",")
    
31.             .InCellDropdown = True
    
32.         End With
    
33.     Case 7
    
34.         For Each cell In rngs '在G列添加数据有效性，将所有目标单元格所在行的E列=A列，并且F列=B列的值，对应的C列的值存入字典key
    
35.             If cell = Target(1).Offset(0, -2) And cell.Offset(0, 1) = Target(1).Offset(0, -1) Then
    
36.                 Dic(cell.Offset(0, 2).Text) = ""
    
37.             End If
    
38.         Next cell
    
39.         With Target(1).Validation
    
40.             .Delete
    
41.             .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=Join(Dic.keys, ",")
    
42.             .InCellDropdown = True
    
43.         End With
    
44.     End Select
    
45.     Dic.RemoveAll
    
46. End Sub

复制代码

hrpotter

C03:hrpotter

1. Option Explicit
   
2. Sub 作业1()
   
3.     Dim arr, brr(1 To 10000, 1 To 12), d
   
4.     Dim i As Long, j As Long, k As Long, n As Long, s As String
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = Sheet1.Range("a1").CurrentRegion
   
7.     For i = 2 To UBound(arr)
   
8.         s = arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6) & arr(i, 7) & arr(i, 8)
   
9.         '将数组中前八项连接起来作为关键字
   
10.         If d.exists(s) Then    '如果该关键字已存在
    
11.             j = d(s)      '取出该关键字在结果数组中的位置
    
12.             brr(j, 10) = brr(j, 10) + arr(i, 10)    '不良数量累加
    
13.             brr(j, 9) = brr(j, 9) & " " & arr(i, 9)    '不良位置用空格连接
    
14.             brr(j, 12) = arr(i, 12)
    
15.         Else              '如果不存在
    
16.             k = k + 1     '计数累加
    
17.             d(s) = k      '添加该关键字进字典，item为结果数组中的行位置
    
18.             For n = 1 To 11
    
19.                 brr(k, n) = arr(i, n)    '循环添加数据
    
20.             Next
    
21.         End If
    
22.     Next
    
23.     Range("a1:f100").ClearContents
    
24.     Range("a1").Resize(1, 12) = Sheet1.Range("a1:l1").Value    '添加标题
    
25.     Range("a2").Resize(k, 12) = brr    '写入结果
    
26.     Sheet5.Name = "第一题答案-" & Format(Time, "hhmm")
    
27. End Sub
    
28. Sub 作业2()
    
29.     Dim arr, brr, crr(1 To 10000, 1 To 6), d
    
30.     Dim i As Long, j As Long, k As Long, s As String
    
31.     Set d = CreateObject("scripting.dictionary")
    
32.     arr = Range("a1").CurrentRegion    '将A组数据放入数组
    
33.     brr = Range("h1").CurrentRegion    '将B组数据放入数组
    
34.     For i = 2 To UBound(arr)
    
35.         s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 5) & "|" & arr(i, 6)
    
36.         '将六个数字用"|"连接放入s字符串作为关键字
    
37.         d(s) = ""    '添加关键字进字典
    
38.     Next
    
39.     For i = 2 To UBound(brr)
    
40.         s = brr(i, 1) & "|" & brr(i, 2) & "|" & brr(i, 3) & "|" & brr(i, 4) & "|" & brr(i, 5) & "|" & brr(i, 6)
    
41.         If d.exists(s) Then    '如果存在，表示该行数据为AB两组中完全相同的数据
    
42.             k = k + 1    '结果数组行位置计数累加
    
43.             For j = 1 To 6
    
44.                 crr(k, j) = brr(i, j)    '循环添加数据
    
45.             Next
    
46.         End If
    
47.     Next
    
48.     Range("o2:t1000").ClearContents
    
49.     Range("o2").Resize(k, 6) = crr    '写入结果
    
50. End Sub
    
51. Sub 作业3()
    
52.     Dim arr, brr, crr, drr(1 To 100, 1 To 3), d
    
53.     Dim i As Long, j As Long, k As Long, s As String
    
54.     Set d = CreateObject("scripting.dictionary")
    
55.     arr = Range("a1").CurrentRegion
    
56.     For i = 2 To UBound(arr)
    
57.         s = arr(i, 1) & "|" & arr(i, 2)    '连接省市，作为关键字
    
58.         If arr(i, 3) <> "" Then    '如果县区不为空，则加入字典
    
59.             If Not d.exists(s) Then    '如果字典中不存在
    
60.                 d(s) = arr(i, 3)    '添加入字典，item直接等于县区
    
61.             Else
    
62.                 If InStr(d(s), arr(i, 3)) = 0 Then    '如果字典中存在，并且item没有重复
    
63.                     d(s) = d(s) & "|" & arr(i, 3)  'item用"|"连接
    
64.                 End If
    
65.             End If
    
66.         End If
    
67.     Next
    
68.     brr = d.keys  '将keys导入数组，方便操作
    
69.     crr = d.items    '将items导入数组
    
70.     For i = 0 To UBound(brr)    '循环keys
    
71.         arr = Split(crr(i), "|")    '将刚才合并的县区拆分
    
72.         For j = 0 To UBound(arr)    '循环相同省市下不同的县区,形成结果数组
    
73.             k = k + 1
    
74.             drr(k, 1) = Split(brr(i), "|")(0)    '将省市拆分开，放入结果数组
    
75.             drr(k, 2) = Split(brr(i), "|")(1)
    
76.             drr(k, 3) = arr(j)
    
77.         Next
    
78.     Next
    
79.     Range("e2:g100").ClearContents
    
80.     Range("e2").Resize(k, 3) = drr    '写入结果
    
81. End Sub

复制代码

cxloen

1. 
   
2. Sub test1()       '作业1代码
   
3. Dim t
   
4. t = Timer
   
5. Dim arr, arr1(1 To 10000, 1 To 12), arr2 'arr用于存放源数据,ARR1用于存放输出数据
   
6. Dim d1 As New Dictionary     '引用字典,新建字典,item用于存放输出数组行号
   
7. 
   
8. 
   
9. 
   
10. Dim i%, j%, k%, n%, m%
    
11. Dim sr1$, sr2$
    
12. 
    
13. i = Sheets("源数据一").Range("a65536").End(xlUp).Row
    
14. 
    
15. 
    
16. arr = Sheets("源数据一").Range("a1:l" & i) '源数据赋值给数组
    
17. arr2 = Sheets("源数据一").Range("a1:l1") '源数据赋值给数组
    
18. 
    
19. For j = 2 To i  '对数组进行循环,关键字为1-8列数据,
    
20.    
    
21.     sr1 = arr(j, 1) & arr(j, 2) & arr(j, 3) & arr(j, 4) & arr(j, 5) & arr(j, 6) & arr(j, 7) & arr(j, 8)
    
22.      If d1.Exists(sr1) Then     '如果字典有此关键字,则对不良数量累加,不良位置增加记录
    
23.         k = d1(sr1)
    
24.         arr1(k, 9) = arr1(k, 9) & " " & arr(j, 9)
    
25.         arr1(k, 10) = arr1(k, 10) + arr(j, 10)
    
26.       
    
27.         k = 0
    
28.    
    
29.     Else                    '如果字典无此关键字,刚将关键字赋值给字典D1的KEY,将原数据赋值给数组ARR1
    
30.         n = n + 1
    
31.         d1(sr1) = n
    
32.         For m = 1 To 12
    
33.          arr1(n, m) = arr(j, m)
    
34.           If Right(sr1, 2) = "连锡" Then arr1(n, 12) = ""   '根据分析,每个生产班组都有假焊和连锡,对于连锡的就不重复统计产量,呵呵,这里偷懒了
    
35.         Next m
    
36.    
    
37.     End If
    
38.    
    
39. Next j
    
40.    
    
41. 
    
42.     Sheets("作业一").Range("a2").Resize(d1.Count, 12) = arr1    '输出数据
    
43.      Sheets("作业一").Range("a1").Resize(1, 12) = arr2      '输出表头
    
44. 
    
45. 
    
46. MsgBox Timer - t    '显示时间
    
47. 
    
48. End Sub
    
49. 
    
50. Sub test2()   '作业2代码
    
51. Dim arr1, arr2, arr3(1 To 10000, 1 To 6)
    
52. Dim d1 As New Dictionary
    
53. Dim d2 As New Dictionary
    
54. Dim sr1$, sr2$, n%, i As Long, k%, j As Long
    
55. 
    
56. i = Range("a65536").End(xlUp).Row
    
57. arr1 = Range("a2:f" & i)
    
58. arr2 = Range("h2:m" & i)
    
59.         For j = 1 To i - 1          '将数据A以1-6列合并赋值给字典D1关键字
    
60.            For k = 1 To 6
    
61.            sr1 = sr1 & arr1(j, k)
    
62.             Next k
    
63.            d1(sr1) = ""
    
64.             sr1 = ""
    
65.             Next j
    
66. 
    
67.         For j = 1 To i - 1              '循环将数据B的1-6列作关键字在字典D1中查找,如果字典D1有此关键字则将该数据赋值给数组ARR3
    
68.             sr2 = arr2(j, 1) & arr2(j, 2) & arr2(j, 3) & arr2(j, 4) & arr2(j, 5) & arr2(j, 6)
    
69.             If d1.Exists(sr2) Then
    
70.                 n = n + 1
    
71.                 arr3(n, 1) = arr2(j, 1)
    
72.                 arr3(n, 2) = arr2(j, 2)
    
73.                 arr3(n, 3) = arr2(j, 3)
    
74.                 arr3(n, 4) = arr2(j, 4)
    
75.                 arr3(n, 5) = arr2(j, 5)
    
76.                 arr3(n, 6) = arr2(j, 6)
    
77.             End If
    
78.         Next
    
79.          
    
80.    
    
81.     Range("o2").Resize(UBound(arr3), 6) = arr3  '输出数据
    
82. 
    
83. End Sub
    
84. 
    
85. Sub test3()     '作业3代码
    
86. Dim arr1, arr2(1 To 1000, 1 To 3)
    
87. Dim d1 As New Dictionary
    
88. Dim d2 As New Dictionary
    
89. Dim i%, k, k1, n%
    
90. 
    
91. arr1 = Range("a2:c" & Range("a65535").End(xlUp).Row)    '数据源写入数组
    
92.     For i = 1 To UBound(arr1)
    
93.      If arr1(i, 3) <> "" Then               '循环,如果第三列不为空则将第三列数据作为关键字,第二列对应值作为ITEM写入字典D1,
    
94.      d1(arr1(i, 3)) = arr1(i, 2)
    
95.      d2(arr1(i, 2)) = arr1(i, 1)            '在前提条件下,将第二列数据作为关键字,第一列作为ITEM写入字典D2
    
96.      End If
    
97.      Next
    
98.    
    
99.   
    
100.      
     
101.         For k = 1 To d2.Count           '对字典D2循环
     
102.             For Each k1 In d1           '针对字典D2对每个字典D1循环
     
103.          
     
104.                  If d1(k1) = d2.Keys(k - 1) Then        '如果字典D1的ITEM等于循环条件下的字典D2的关键字,将第三列唯一值的对应的第二列数据及第一列数据放入数组中
     
105.                     n = n + 1
     
106.                     arr2(n, 3) = k1
     
107.                     arr2(n, 2) = d1(k1)
     
108.                     arr2(n, 1) = d2(d1(k1))
     
109.                 End If
     
110.              Next
     
111. 
     
112.         Next
     
113. 
     
114.     Range("e2").Resize(d1.Count, 3) = arr2  '输出
     
115. End Sub
     

复制代码

sayloveyou2010

C01:sayloveyou2010 小妮子

1. 
   
2. Sub 作业一()
   
3.     Dim dic As New Dictionary, arr(), x%, y%
   
4.     With Sheets("源数据一")
   
5.         Myrow = .Cells(Rows.Count, 1).End(xlUp).Row
   
6.         arr = .Range("A2:L" & Myrow).Value
   
7.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
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 Not dic.Exists(m) Then '判断是否存在
    
11.                 n = n + 1
    
12.                 dic.Add m, n '添加字典
    
13.                 For y = 1 To UBound(brr, 2) - 4 '循环条件列
    
14.                     brr(n, y) = arr(x, y) '装入结果数组
    
15.                 Next y
    
16.                 For y = 9 To 12 '循环结果列
    
17.                     brr(n, y) = arr(x, y)
    
18.                 Next y
    
19.                 If brr(n, 9) = "IC" Then brr(n, 12) = "" 'IC产量为空
    
20.             Else
    
21.                 brr(dic(m), 9) = brr(dic(m), 9) & " " & arr(x, 9) '连接不良位置
    
22.                 brr(dic(m), 10) = brr(dic(m), 10) + arr(x, 10) '不良数量
    
23.                 brr(dic(m), 11) = arr(x, 11) '产量
    
24.             End If
    
25.         Next x
    
26.     End With
    
27.     Set sh = Sheets.Add(before:=Sheets("作业一"))
    
28.     With sh
    
29.         .Range("A1:L1") = Array("生产日期", "编号", "周期", "月份", "产品型号", "生产线", "班组", "不良类型", "不良位置", "不良数量", "备注", "产量")
    
30.         .Range("A1:A" & dic.Count + 1).NumberFormatLocal = "yyyy-m-d"
    
31.         .Range("A2").Resize(UBound(brr), 12) = brr '读出
    
32.         .Cells.EntireColumn.AutoFit
    
33.         .Name = "第一题答案_" & Format(Now(), "hhmm")
    
34.     End With
    
35. End Sub
    
36. '==================================================================================================
    
37. Sub 作业二()
    
38.     Dim arr(), brr(), dic As New Dictionary, x&, y%, mm, nn
    
39.     arr = Range("A2:M" & Cells(Rows.Count, 1).End(xlUp).Row)
    
40.     ReDim brr(1 To UBound(arr), 1 To 6)
    
41.     For x = 1 To UBound(arr)
    
42.         mm = arr(x, 1) & vbTab & arr(x, 2) & vbTab & arr(x, 3) & vbTab & arr(x, 4) & vbTab & arr(x, 5) & vbTab & arr(x, 6) '连接
    
43.         If Not dic.Exists(mm) Then '判断是否存在，如果不存在
    
44.             dic.Add mm, "" '添加字典
    
45.         End If
    
46.     Next x
    
47.     For x = 1 To UBound(arr)
    
48.         nn = arr(x, 8) & vbTab & arr(x, 9) & vbTab & arr(x, 10) & vbTab & arr(x, 11) & vbTab & arr(x, 12) & vbTab & arr(x, 13) '连接
    
49.         If dic.Exists(nn) Then '在B里查找A如果查找到
    
50.             k = k + 1 '计数器
    
51.             For y = 1 To UBound(brr, 2) '循环列
    
52.                 brr(k, y) = Split(nn, vbTab)(y - 1) '分列结果装入结果数组
    
53.             Next y
    
54.         End If
    
55.     Next x
    
56.     Range("O2").Resize(2, 6) = brr '读出
    
57.     End Sub
    
58. '===============================================================================================
    
59. Sub 作业三()
    
60.     Dim dic As New Dictionary, arr(), x%, mm
    
61.     arr = Range("A2:C" & Cells(Rows.Count, 1).End(xlUp).Row)
    
62.     ReDim brr(1 To UBound(arr), 1 To 3)
    
63.     For x = 1 To UBound(arr)
    
64.         mm = arr(x, 1) & vbTab & arr(x, 2) & vbTab & arr(x, 3) '连接
    
65.         If Not dic.Exists(mm) Then '如果不存在
    
66.             dic.Add mm, "" '添加字典
    
67.         End If
    
68.     Next x
    
69.     For x = 0 To dic.Count - 1 '循环字典
    
70.         If Split(dic.Keys(x), vbTab)(0) = "湖北" Then '如果找到湖北
    
71.             k = k + 1 '计数器
    
72.             brr(k, 1) = "湖北" '省
    
73.             brr(k, 2) = Split(dic.Keys(x), vbTab)(1) '市
    
74.             brr(k, 3) = Split(dic.Keys(x), vbTab)(2) '县
    
75.         End If
    
76.     Next x
    
77.     [E2].Resize(k, 3) = brr '读出
    
78.     ActiveWorkbook.Worksheets("作业三").AutoFilter.Sort.SortFields.Clear
    
79.     ActiveWorkbook.Worksheets("作业三").AutoFilter.Sort.SortFields.Add Key:=Range( _
    
80.         "F1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    
81.         xlSortNormal '排序
    
82.     With ActiveWorkbook.Worksheets("作业三").AutoFilter.Sort
    
83.         .Header = xlYes
    
84.         .MatchCase = False
    
85.         .Orientation = xlTopToBottom
    
86.         .SortMethod = xlPinYin
    
87.         .Apply
    
88.     End With
    
89. End Sub
    

复制代码

Sellby

1. Option Explicit
   
2. 
   
3. Sub 作业一()
   
4.     Dim arr
   
5.     Dim d As New Dictionary, sh As Worksheet
   
6.     Dim i%, j%, n%
   
7.     Dim str$
   
8.     arr = Sheets("源数据一").Range("a1").CurrentRegion.Value '将数据源数据放入数组
   
9.     n = 1
   
10.     For i = 2 To UBound(arr) '对数组进行行循环
    
11.         '将A-H列的数据连接起来作为字典的KEY
    
12.         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)
    
13.          '判断字典中KEY是否存在
    
14.         If d.Exists(str) Then '如果存在
    
15.             arr(d(str), 9) = arr(d(str), 9) & " " & arr(i, 9) '不良位置添加
    
16.             arr(d(str), 10) = arr(d(str), 10) + arr(i, 10) '不良数量累计
    
17.         Else '如果不存在
    
18.             n = n + 1
    
19.             d(str) = n '增加KEY
    
20.             For j = 1 To 11 '对数组进行列循环
    
21.                arr(n, j) = arr(i, j) '利用原来数组，将对应的数据放入，也可以声明一个新的数组，放到新的数组中
    
22.             Next j
    
23.             arr(n, 12) = IIf(arr(i, 8) = "连锡", "", arr(i, 12)) '最后一列数据按条件显示
    
24.       End If
    
25.     Next i
    
26.     Set sh = Sheets.Add(after:=Sheets(Sheets.Count)) '创建一个新工作表，放在最后
    
27.     sh.Name = "第一题答案-" & Format(Now(), "hhmm") '新工作表命名
    
28.     sh.Range("a1").Resize(n, 12) = arr '写入结果
    
29.     Set d = Nothing '释放对象
    
30. End Sub
    
31. 
    
32. 
    
33. Sub 作业二()
    
34.     Dim arr1, arr2
    
35.     Dim d As New Dictionary
    
36.     Dim i&, j%, n%
    
37.     Dim str$
    
38.     With Sheets("作业二")
    
39.         arr1 = .Range("a2:f" & Cells(Rows.Count, "f").End(3).Row).Value 'A组数据读入数组
    
40.         arr2 = .Range("h2:m" & Cells(Rows.Count, "f").End(3).Row).Value 'B组数据读入数组
    
41.         For i = 1 To UBound(arr1) 'A组数组行循环
    
42.             '将一行数据连接在一起，作为KEY放入字典
    
43.             str = arr1(i, 1) & "|" & arr1(i, 2) & "|" & arr1(i, 3) & "|" & arr1(i, 4) & "|" & arr1(i, 5) & "|" & arr1(i, 6)
    
44.             d(str) = ""
    
45.         Next i
    
46.         For i = 1 To UBound(arr2) 'B组数组行循环
    
47.             '将一行数据连接在一起，作为KEY判断字典中是否存在
    
48.             str = arr2(i, 1) & "|" & arr2(i, 2) & "|" & arr2(i, 3) & "|" & arr2(i, 4) & "|" & arr2(i, 5) & "|" & arr2(i, 6)
    
49.             If d.Exists(str) Then '如果存在
    
50.                 n = n + 1 '对存在的数据个数进行累计
    
51.                 For j = 1 To 6 '对数组进行列循环
    
52.                     arr2(n, j) = arr2(i, j) '利用原来数组，将对应的数据放入，也可以声明一个新的数组，放到新的数组中
    
53.                 Next j
    
54.             End If
    
55.         Next i
    
56.         .Range("o2:t" & Cells(Rows.Count, "f").End(3).Row).ClearContents '清空单元格
    
57.         .Range("o2").Resize(n, 6) = arr2 '写入结果
    
58.     End With
    
59.     Set d = Nothing '释放对象
    
60. End Sub
    
61. 
    
62. 
    
63. Sub 作业三()
    
64.     Dim arr, tempArr
    
65.     Dim d As New Dictionary
    
66.     Dim i&, j%, m As Byte, n As Byte
    
67.     Dim str$
    
68.     With Sheets("作业三")
    
69.         arr = .Range("a1").CurrentRegion.Value '数据读入数组
    
70.         For i = 2 To UBound(arr) '对数组进行循环
    
71.             If arr(i, 1) = "湖北" Then '判断第一列=湖北时，执行下面语句
    
72.                 '判断字典中以第二列市为KEY是否存在
    
73.                 If d.Exists(arr(i, 2)) Then '如果存在
    
74.                     If InStr(d(arr(i, 2)), arr(i, 3)) = 0 Then '判断如果该KEY所对应的ITEM中不包含第三列县的内容
    
75.                         d(arr(i, 2)) = d(arr(i, 2)) & "|" & arr(i, 3) '将该县添加到ITEM中
    
76.                     End If
    
77.                 Else '如果不存在
    
78.                     d(arr(i, 2)) = arr(i, 3) '在字典中增加一个KEY，市为KEY，县为ITEM
    
79.                 End If
    
80.             End If
    
81.         Next i
    
82.         Stop
    
83.         n = 2
    
84.         For i = 0 To d.Count - 1 '对字典进行循环
    
85.             tempArr = Split(d.Items(i), "|") '将ITEM分列，赋给数组tempArr
    
86.             m = UBound(tempArr)
    
87.             For j = 0 To m '对数组tempArr循环
    
88.                 '利用原来数组，将对应的数据放入，也可以声明一个新的数组，放到新的数组
    
89.                 arr(n + j, 1) = "湖北" '第一列：省（湖北）
    
90.                 arr(n + j, 2) = d.Keys(i) '第二列：市（字典的KEY）'清空单元格
    
91.                 arr(n + j, 3) = tempArr(j) '第三列：县（tempArr的值）
    
92.           Next j
    
93.           n = n + m + 1 '确定
    
94.        Next i
    
95.         .Range("e:g").ClearContents '清空单元格
    
96.         .Range("e1").Resize(n - 1, 3) = arr '写入结果
    
97.     End With
    
98.     Set d = Nothing '释放对象
    
99. End Sub
    

复制代码

先交了吧，好纠结的

hoogle

1. Option Explicit
   
2. Sub 作业一()
   
3. Dim arrData, arrRes()
   
4. Dim i, j, m, n, d, strTemp
   
5. Set d = CreateObject("scripting.dictionary")
   
6. arrData = Sheet1.Range("a1").CurrentRegion
   
7. ReDim arrRes(1 To UBound(arrData), 1 To UBound(arrData, 2))
   
8. For i = 1 To UBound(arrData)
   
9.     strTemp = Join(Array(arrData(i, 1), arrData(i, 2), arrData(i, 3), arrData(i, 4), _
   
10.     arrData(i, 5), arrData(i, 6), arrData(i, 7), arrData(i, 8)), "|")
    
11.     If Not d.exists(strTemp) Then
    
12.         m = m + 1
    
13.         For j = 1 To UBound(arrData, 2)
    
14.             arrRes(m, j) = arrData(i, j)
    
15.         Next
    
16.         n = n + 1
    
17.         d(strTemp) = n
    
18.     Else
    
19.         arrRes(d(strTemp), 9) = arrRes(d(strTemp), 9) & " " & arrData(i, 9)
    
20.         arrRes(d(strTemp), 10) = arrRes(d(strTemp), 10) + arrData(i, 10)
    
21.     End If
    
22. Next
    
23. Sheet3.UsedRange.ClearContents
    
24. Sheet3.Range("a1").Resize(UBound(arrRes), UBound(arrRes, 2)) = arrRes
    
25. End Sub
    
26. 
    
27. Sub 作业二()
    
28. Dim arrA, arrB, i, j, d, arrRes(), strTemp, t
    
29. Sheet6.Select
    
30. arrA = Range("a2").CurrentRegion
    
31. arrB = Range("h2").CurrentRegion
    
32. Set d = CreateObject("scripting.dictionary")
    
33. For i = 1 To UBound(arrA)
    
34.     strTemp = Join(Array(arrA(i, 1), arrA(i, 2), arrA(i, 3), arrA(i, 4), arrA(i, 5), arrA(i, 6)), "，")
    
35.     d(strTemp) = 1
    
36. Next
    
37. For i = 1 To UBound(arrB)
    
38.     strTemp = Join(Array(arrB(i, 1), arrB(i, 2), arrB(i, 3), arrB(i, 4), arrB(i, 5), arrB(i, 6)), "，")
    
39.     If d.exists(strTemp) Then
    
40.         t = t + 1
    
41.         ReDim Preserve arrRes(1 To 6, 1 To t)
    
42.         For j = 1 To 6
    
43.             arrRes(j, t) = arrB(i, j)
    
44.         Next
    
45.     End If
    
46. Next
    
47. Range("O2").CurrentRegion.Offset(1).ClearContents
    
48. Range("O2").Resize(t, 6) = Application.Transpose(arrRes)
    
49. End Sub
    
50. 
    
51. Sub 作业三()
    
52. Dim arrData, arrRes(1 To 100, 1 To 3), i, j, m, n, d, strT, intT, t, t2, t3
    
53. Sheet7.Select
    
54. arrData = Range("a1").CurrentRegion
    
55. Set d = CreateObject("scripting.dictionary")
    
56. For i = 2 To UBound(arrData)
    
57.     If arrData(i, 3) <> "" Then
    
58.         If Not d.exists(arrData(i, 1)) Then Set d(arrData(i, 1)) = CreateObject("scripting.dictionary")
    
59.         If Not d(arrData(i, 1)).exists(arrData(i, 2)) Then Set d(arrData(i, 1))(arrData(i, 2)) = CreateObject("scripting.dictionary")
    
60.         d(arrData(i, 1))(arrData(i, 2))(arrData(i, 3)) = ""
    
61.     End If
    
62. Next
    
63. t = d.keys
    
64. For i = 0 To UBound(t)
    
65.     t2 = d(t(i)).keys
    
66.     For j = 0 To UBound(t2)
    
67.         t3 = d(t(i))(t2(j)).keys
    
68.         For m = 0 To UBound(t3)
    
69.             n = n + 1
    
70.             arrRes(n, 1) = t(i)
    
71.             arrRes(n, 2) = t2(j)
    
72.             arrRes(n, 3) = t3(m)
    
73.         Next
    
74.     Next
    
75. Next
    
76. Range("E2").Resize(100, 3) = arrRes
    
77. End Sub

复制代码

箫风

C05：箫风

1.      
   
2. Sub 作业一()
   
3.     Dim arr, arr1, arr2, arr3, arr4
   
4.     Dim i As Integer, j As Integer, s As String, t
   
5.     Dim d As New Dictionary, d1 As New Dictionary, d2 As New Dictionary
   
6.     Application.DisplayAlerts = False
   
7.     Range("O2:T" & Cells(Rows.Count, "O").End(xlUp).Row).ClearContents
   
8.    
   
9.     For i = 1 To Sheets.Count
   
10.         On Error Resume Next
    
11.         If Sheets(i).Name Like "第一题答案*" Then Sheets(i).Delete
    
12.     Next i
    
13.     t = Timer
    
14.     arr = Range("A1:L" & Cells(Rows.Count, 1).End(xlUp).Row)
    
15.     '将不重复的项放入字典
    
16.     For i = 2 To UBound(arr)
    
17.         s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 5) & "|" & arr(i, 6) & "|" & arr(i, 7) & "|" & arr(i, 8) & "|" & arr(i, 11) & "|" & arr(i, 12)
    
18.         d(s) = "" ' + arr(i, 10)
    
19.     Next i
    
20.     arr1 = Range("A2:L" & Cells(Rows.Count, 1).End(3).Row).Value
    
21.     '累计不良位置不良记录
    
22.     For i = 1 To UBound(arr1)
    
23.         s = arr1(i, 1) & "|" & arr1(i, 2) & "|" & arr1(i, 3) & "|" & arr1(i, 4) & "|" & arr1(i, 5) & "|" & arr1(i, 6) & "|" & arr1(i, 7) & "|" & arr1(i, 8) & "|" & arr1(i, 11) & "|" & arr1(i, 12)
    
24.         d1(s) = d1(s) + " " + arr1(i, 9)
    
25.         d2(s) = d2(s) + arr1(i, 10)
    
26.     Next i
    
27.     arr2 = d.Keys
    
28.     '准备写入目标工作表中的数据
    
29.     ReDim arr4(0 To d.Count, 0 To UBound(arr1, 2) - 3)
    
30.     For i = 0 To d.Count - 1
    
31.         arr3 = Split(arr2(i), "|")
    
32.         For j = 0 To UBound(arr1, 2) - 3
    
33.             arr4(i, j) = arr3(j)
    
34.             If arr3(7) = "连锡" Then arr4(i, 9) = ""
    
35.         Next j
    
36.     Next i
    
37.     Sheets.Add
    
38.     '将数据依次写入目标工作表
    
39.     Range("A1").Resize(, UBound(arr, 2)) = Application.WorksheetFunction.Index(arr, 1)
    
40.     Range("A2").Resize(UBound(arr4, 1), UBound(arr4, 2) + 1) = arr4
    
41.     Range("I2").Resize(UBound(arr4, 1), 2).Insert Shift:=xlToRight
    
42.     Range("I2").Resize(UBound(arr4, 1), 1) = Application.WorksheetFunction.Transpose(d1.Items)
    
43.     Range("J2").Resize(UBound(arr4, 1), 1) = Application.WorksheetFunction.Transpose(d2.Items)
    
44.     Columns("A:L").EntireColumn.AutoFit
    
45.     ActiveSheet.Name = "第一题答案-" & Timer - t
    
46.     Sheets("作业一").Select
    
47.     Application.DisplayAlerts = True
    
48.    
    
49. End Sub
    
50. 
    
51. 
    
52. Sub 作业二()
    
53.     Dim arr1, arr2, arr3, arr4
    
54.     Dim s As String
    
55.     Dim d1 As New Dictionary
    
56.     Dim d2 As New Dictionary
    
57.     Dim i As Long, j As Long
    
58.    
    
59.     Range("O2:S" & Rows.Count).ClearContents
    
60.     arr1 = Range("A2:F" & Cells(Rows.Count, "A").End(xlUp).Row).Value
    
61.     arr2 = Range("H2:M" & Cells(Rows.Count, "H").End(xlUp).Row).Value
    
62.     For i = LBound(arr1) To UBound(arr1)
    
63.         s = arr1(i, 1) & "|" & arr1(i, 2) & "|" & arr1(i, 3) & "|" & arr1(i, 4) & "|" & arr1(i, 5) & "|" & arr1(i, 6)
    
64.         
    
65.         d1(s) = ""
    
66.     Next
    
67.    
    
68.     For i = LBound(arr2) To UBound(arr2)
    
69.         'A组和B组共有值
    
70.         s = arr2(i, 1) & "|" & arr2(i, 2) & "|" & arr2(i, 3) & "|" & arr2(i, 4) & "|" & arr2(i, 5) & "|" & arr2(i, 6)
    
71.         
    
72.         If d1.Exists(s) Then d2(s) = ""
    
73.     Next
    
74.     If d2.Count = 0 Then Exit Sub
    
75.     arr3 = d2.Keys
    
76.     '准备写入目标区域中的数据
    
77.     ReDim arr5(0 To d2.Count, 0 To UBound(arr1, 2) - 1)
    
78.    
    
79.     For i = 0 To d2.Count - 1
    
80.         arr4 = Split(arr3(i), "|")
    
81.         For j = 0 To UBound(arr1, 2) - 1
    
82.             arr5(i, j) = arr4(j)
    
83.         Next j
    
84.     Next i
    
85.     '将数据写入目标区域
    
86.     Range("O2").Resize(UBound(arr5, 1), UBound(arr5, 2)).Value = arr5
    
87.     MsgBox "提取完成！"
    
88. End Sub
    
89. 
    
90. Sub 作业三()
    
91.     Dim arr1, arr2, arr3, arr4
    
92.     Dim s As String
    
93.     Dim d As New Dictionary
    
94.     Dim i As Long, j As Long, k As Long, l As Long
    
95.    
    
96.     Range("E2:G" & Rows.Count).ClearContents
    
97.     arr1 = Range("A2:C" & Cells(Rows.Count, "A").End(xlUp).Row).Value
    
98.     For i = LBound(arr1) To UBound(arr1)
    
99.         s = arr1(i, 1) & "|" & arr1(i, 2) & "|" & arr1(i, 3)
    
100.         d(s) = ""
     
101.     Next
     
102.     If d.Count = 0 Then Exit Sub
     
103.     arr2 = d.Keys
     
104.    
     
105.    
     
106.     '准备写入目标区域中的数据
     
107.     ReDim arr4(0 To d.Count, 0 To UBound(arr1, 2) - 1)
     
108.     k = 0
     
109.     l = 0
     
110.     '剔除县区为空数据行
     
111.     Do
     
112.         If Len(arr2(l)) > 6 Then
     
113.             arr3 = Split(arr2(l), "|")
     
114.             For j = 0 To UBound(arr1, 2) - 1
     
115.                 arr4(l - k, j) = arr3(j)
     
116.             Next j
     
117.         Else
     
118.             k = k + 1
     
119.         End If
     
120.         l = l + 1
     
121.     Loop Until l = d.Count
     
122.     '将数据写入目标区域
     
123.     Range("E2").Resize(UBound(arr4, 1) + 1, UBound(arr4, 2) + 1).Value = arr4
     
124.    
     
125. End Sub
     

复制代码