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

sliang28 · 发表于 2013-11-22 17:06

本帖最后由 sliang28 于 2013-11-29 15:12 编辑

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

作业要求：
	1.要求使用字典完成
	2.所有的代码均写在按钮指定的过程中
	3.要求代码缩进
	4.要求有注释（关键代码处）
	5.要求强制声明备注:只需要将代码贴出来即可,大家看清楚了{:3912:}

风林火山 · 发表于 2013-11-23 10:45

本帖最后由风林火山于 2013-11-23 15:08 编辑

Sub work1()
Dim arr, brr()
Dim k%, i%, h%, str$
Dim d As New Dictionary
arr = Worksheets("源数据一").Range("a1:l" & Worksheets("源数据一").Cells(Rows.Count, 1).End(3).Row) '数组赋值
ReDim brr(1 To UBound(arr), 1 To 12) '重新定义数组
i = 2
For k = 2 To UBound(arr)
Rem 定义变量字符串
str = arr(k, 1) & arr(k, 2) & arr(k, 3) & arr(k, 4) & arr(k, 5) & arr(k, 6) & arr(k, 7) & arr(k, 8)
'下棋法获取数据:
If d.Exists(str) = False Then
d.Item(str) = i '用字典保存行号
brr(i, 1) = arr(k, 1): brr(i, 2) = arr(k, 2)
brr(i, 3) = arr(k, 3): brr(i, 4) = arr(k, 4)
brr(i, 5) = arr(k, 5): brr(i, 6) = arr(k, 6)
brr(i, 7) = arr(k, 7): brr(i, 8) = arr(k, 8)
brr(i, 9) = arr(k, 9): brr(i, 10) = arr(k, 10)
brr(i, 11) = arr(k, 11): brr(i, 12) = arr(k, 12)
i = i + 1
Else
h = d.Item(str) '提取行号
brr(h, 9) = brr(h, 9) & " " & arr(k, 9)
brr(h, 10) = brr(h, 10) + arr(k, 10)
brr(h - 1, 12) = ""
End If
Next k
'定义标题
brr(1, 1) = ("生产日期"): brr(1, 2) = ("编号")
brr(1, 3) = ("周期"): brr(1, 4) = ("月份")
brr(1, 5) = ("产品型号"): brr(1, 6) = ("生产线")
brr(1, 7) = ("班组"): brr(1, 8) = ("不良类型")
brr(1, 9) = ("不良位置"): brr(1, 10) = ("不良数量")
brr(1, 11) = ("备注"): brr(1, 12) = ("产量")
Worksheets.Add '新建工作表
ActiveSheet.[a1].Resize(UBound(brr), 12) = brr '显示数据
ActiveSheet.Name = "第一题答案" & "-" & Format(Time, "hhmm") '工作表命名
End Sub
Sub work2()
Dim arr, brr, crr(1 To 10000, 1 To 6)
Dim i&, k&, n&, str1, str2
Dim d1 As New Dictionary
On Error Resume Next '容错
arr = Range("a2:f" & Cells(Rows.Count, 6).End(xlUp).Row) '数组赋值
brr = Range("h2:m" & Cells(Rows.Count, 13).End(xlUp).Row) '数组赋值
For i = 1 To UBound(arr) - 1
str1 = arr(i, 1) & "@" & arr(i, 2) & "@" & arr(i, 3) & "@" & arr(i, 4) & "@" & arr(i, 5) & "@" & arr(i, 6)
d1.Item(str1) = "" 'A组数据生成不重复数据
Next i
For k = 1 To UBound(brr) - 1
str2 = brr(k, 1) & "@" & brr(k, 2) & "@" & brr(k, 3) & "@" & brr(k, 4) & "@" & brr(k, 5) & "@" & brr(k, 6)
If d1.Exists(str2) = True Then '判断B组数据和A组数据相同数据
n = n + 1
'生成数据
crr(n, 1) = brr(k, 1): crr(n, 2) = brr(k, 2): crr(n, 3) = brr(k, 3): crr(n, 4) = brr(k, 4): crr(n, 5) = brr(k, 5): crr(n, 6) = brr(k, 6)
End If
Next k
'显示数据
Range("o:t").ClearComments
Range("o1") = "C"
Range("o1:t1").Merge
Range("o1:t1").HorizontalAlignment = xlCenter
Range("o2").Resize(UBound(crr), 6) = crr
End Sub
Sub work3()
Dim arr, brr()
Dim d As New Dictionary
Dim k%, i%, m%, str As String
arr = Worksheets("作业三").Range("a1:c25")
For k = 2 To UBound(arr)
str = arr(k, 1) & " " & arr(k, 2) & " " & arr(k, 3)
If InStr(str, "湖北") Then '生成包含湖北的不重复数据
d.Item(str) = k
End If
Next k
ReDim brr(1 To d.Count, 1 To 3) '重新定义数组
For i = 1 To d.Count
For m = 1 To 3
brr(i, m) = Split(d.Keys(i - 1), " ")(m - 1) '拆分数据
Next m
Next i
Worksheets("作业三").[e2].Resize(d.Count, 3) = brr '显示数据
End Sub

复制代码

w2001pf · 发表于 2013-11-23 17:57

D05:w2001pf

Sub 作业1()
Dim arr1, t, t2, sr
Dim d1 As New Dictionary
Dim i As Long, j As Long, k As Long, m As Long
t = Timer
Sheets("源数据一").Select '定义一个装结果的数组
arr1 = Sheets("源数据一").Range("A1:L" & Cells(Rows.Count, "A").End(xlUp).Row).Value '把源数据装入数组中
ReDim arrjg(1 To UBound(arr1), 1 To UBound(arr1, 2))
For i = 1 To UBound(arr1)
      sr = arr1(i, 1) & "," & arr1(i, 5) & "," & arr1(i, 6) & "," & arr1(i, 7) & "," & arr1(i, 8)
      If d1.Exists(sr) = False Then '当关键字第一次出现时
         k = k + 1
         d1(sr) = k '计算关键字第一次的行数
         For j = 1 To UBound(arr1, 2) '关键字第一次出现时，把相应的内容写入数组中
            arrjg(k, j) = arr1(i, j)
         Next j
      Else
         m = d1(sr)
         arrjg(m, 9) = arrjg(m, 9) & " " & arr1(i, 9) '当关键字不是第一次出现时，把位置连接起来，把数量相加
         arrjg(m, 10) = arrjg(m, 10) + arr1(i, 10)
      End If
Next
t2 = Timer - t
Worksheets.Add after:=Sheets(Sheets.Count)  '在所有表最右边插入一表
ActiveSheet.Name = "第一题答案-" & t2
On Error Resume Next
ActiveSheet.Select
Range("A1").Resize(UBound(arrjg), UBound(arrjg, 2)) = arrjg
Cells.Columns.AutoFit
End Sub
Sub 作业2()
Dim arr1, arr2, arrjg(), arrgd
Dim d1 As New Dictionary
Dim d2 As New Dictionary
Dim i As Long, j As Long

arr1 = Range("A2:F" & Cells(Rows.Count, "A").End(xlUp).Row).Value '把A组数据装入数组中
arr2 = Range("H2:M" & Cells(Rows.Count, "H").End(xlUp).Row).Value '把B组数据装入数组中
For i = 1 To UBound(arr1)
      d1(arr1(i, 1) & "," & arr1(i, 2) & "," & arr1(i, 3) & "," & arr1(i, 4) & "," & arr1(i, 5) & "," & arr1(i, 6)) = ""
      '通过字典d1去掉A组数据的重复值，把A组数据的一行六列作为关键字
Next

For i = 1 To UBound(arr2)
      If d1.Exists(arr2(i, 1) & "," & arr2(i, 2) & "," & arr2(i, 3) & "," & arr2(i, 4) & "," & arr2(i, 5) & "," & arr2(i, 6)) Then
         d2(arr2(i, 1) & "," & arr2(i, 2) & "," & arr2(i, 3) & "," & arr2(i, 4) & "," & arr2(i, 5) & "," & arr2(i, 6)) = ""
      End If '如果A组数据中存在的就在B组数据中去掉重复值
Next
arrgd = d2.Keys
ReDim arrjg(1 To d2.Count, 1 To UBound(arr1, 2)) '定义一个结果数组
For i = 0 To d2.Count - 1
      For j = 0 To 5
         arrjg(i + 1, j + 1) = Split(arrgd(i), ",")(j) '通过Split函数分列字典d2的关键字装入结果数组中
      Next j
Next i
Range("O2:T" & Cells(Rows.Count, "O").End(xlUp).Row).ClearContents
Range("O2").Resize(UBound(arrjg), UBound(arrjg, 2)) = arrjg
End Sub
Sub 作业3()
Dim arr1, arr2, arrjg(), arrgd, arrss
Dim d1 As New Dictionary
Dim d2 As New Dictionary
Dim i As Long, j As Long

arr1 = Range("A2:C" & Cells(Rows.Count, "A").End(xlUp).Row).Value '把源数据装入数组中
For i = 1 To UBound(arr1)
      If arr1(i, 3) <> "" Then d1(arr1(i, 1) & "," & arr1(i, 2)) = ""
      '如果第三列不为空，则通过字典d1去掉源数据的重复值，把源数据的一行两列作为关键字
Next
arrss = d1.Keys '把字典d1的关键字装入数组中
For j = 0 To d1.Count - 1
      For i = 1 To UBound(arr1)
         If arr1(i, 1) & "," & arr1(i, 2) = arrss(j) Then
            d2(arr1(i, 1) & "," & arr1(i, 2) & "," & arr1(i, 3)) = ""
         End If '如果字典d1的关键字存在的就在源数据中去掉重复值
      Next
Next j
arrgd = d2.Keys
ReDim arrjg(1 To d2.Count, 1 To UBound(arr1, 2)) '定义一个结果数组
For i = 0 To d2.Count - 1
      For j = 0 To 2
         arrjg(i + 1, j + 1) = Split(arrgd(i), ",")(j) '通过Split函数分列字典d2的关键字装入结果数组中
      Next j
Next i
Range("E2:G" & Cells(Rows.Count, "E").End(xlUp).Row).ClearContents
Range("E2").Resize(UBound(arrjg), UBound(arrjg, 2)) = arrjg
End Sub

fffox · 发表于 2013-11-25 10:15

交作业了

Option Explicit
Sub 作业一() 'by D09:fffox
Dim arr, arr1, brr(), t
Dim d As New Dictionary
Dim str$, i As Byte, j As Byte, k As Byte, iRow As Byte
Dim sh As Object
t = Timer
With Sheets("源数据一")
arr = .Range("a2", .Cells(Rows.Count, "l").End(xlUp)).Value
arr1 = .Range("a1:l1").Value
End With
'按数值区域大小创建足够大的目标数组brr
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
For i = LBound(arr) To UBound(arr)
'以数据源前8列为关键字进行对比
str = ""
For j = 1 To 8
str = str & arr(i, j)
Next j
If Not d.Exists(str) Then
'字典中不存在，则相应数据存入目标数组
k = k + 1
d(str) = k
For j = LBound(arr, 2) To UBound(arr, 2) - 1
brr(k, j) = arr(i, j)
Next
'产量列，如果不良类型为“连锡”则为空，否则取值
If arr(i, 8) = "连锡" Then
brr(k, 12) = ""
Else
brr(k, 12) = arr(i, 12)
End If
Else
'如果字典存在，则在对应行进行处理
iRow = d(str)
brr(iRow, 9) = brr(iRow, 9) & " " & arr(i, 9) '不良位置
brr(iRow, 10) = brr(iRow, 10) + arr(i, 10) '不良数量增加
End If
Next
'创建新工作表并写入数据，工作表命名
Set sh = Sheets.Add
With sh
.Range("a1:l1") = arr1
.Range("a2").Resize(k, UBound(arr, 2)) = brr
.Columns("a:l").AutoFit
.Name = "第一题答案-" & Timer - t
End With
Set sh = Nothing
End Sub
Sub 作业二() 'by D09:fffox
Dim d1 As New Dictionary
Dim str$, i&, j As Byte, k&
Dim arr, brr() As Byte, t
t = Timer
With Sheets("作业二")
arr = .Range("a2").CurrentRegion
'在A组中循环，以每一行数值为关键字创建字典
For i = 2 To UBound(arr)
For j = 1 To 6
str = str & "*" & arr(i, j)
Next
d1(str) = ""
str = ""
Next
arr = .Range("h2").CurrentRegion
'在B组中循环，以每行数值为关键字判断字典是否存在
'若存在，则说明该行数据一样，保存到数组brr中
For i = 2 To UBound(arr)
For j = 1 To 6
str = str & "*" & arr(i, j)
Next
If d1.Exists(str) Then
k = k + 1
ReDim Preserve brr(1 To 6, 1 To k) As Byte
For j = 1 To 6
brr(j, k) = arr(i, j)
Next
End If
str = ""
Next
'清空目标区域并把数组brr写入目标区域
.Range("o2", Cells(Rows.Count, "t")).ClearContents
.Range("o2").Resize(k, 6) = Application.Transpose(brr)
End With
Debug.Print Timer - t
End Sub
Sub 作业三() 'by D09:fffox
Dim dic As New Dictionary
Dim arr, brr()
Dim i%, j%, k%, str1$, str2$
With Sheets("作业三")
arr = .Range("a2").CurrentRegion
For i = 2 To UBound(arr)
If arr(i, 3) = "" Then GoTo 100
'根据题目要求，县区为空的跳过
str1 = arr(i, 1) & arr(i, 2)
If Not dic.Exists(str1) Then
dic(str1) = "" '为第一次出现的省市创建字典
For j = i To UBound(arr)
str2 = arr(j, 1) & arr(j, 2)
'省市相同且省市县首次出现的，创建字典并为目标数组赋值
If str1 = str2 And Not dic.Exists(str2 & arr(j, 3)) Then
dic(str2 & arr(j, 3)) = ""
k = k + 1
ReDim Preserve brr(1 To 3, 1 To k)
brr(1, k) = arr(j, 1)
brr(2, k) = arr(j, 2)
brr(3, k) = arr(j, 3)
End If
Next
End If
100
Next
.Range("e2", Cells(Rows.Count, "g")).ClearContents
.Range("e2").Resize(k, 3) = WorksheetFunction.Transpose(brr)
.Columns("e:g").HorizontalAlignment = xlCenter '居中
End With
End Sub

复制代码

一杯清荼 · 发表于 2013-11-25 15:15

本帖最后由一杯清荼于 2013-11-25 18:05 编辑

Sub 作业一()
'主要思路：下棋法
Dim i As Integer, j As Integer, m As Integer, st As String, t As Double
Dim d As New Dictionary, arr, brr(1 To 200, 1 To 12)
t = Timer
arr = [a1].CurrentRegion
For i = 1 To UBound(arr)
st = arr(i, 1) & arr(i, 2) & arr(i, 5) & arr(i, 7) & arr(i, 8)
If Not d.Exists(st) Then
d(st) = d.Count + 1
For j = 1 To 11
brr(d.Count, j) = arr(i, j)
Next
If brr(d.Count, 9) <> "IC" Then brr(d.Count, 12) = arr(i, 12) '不良位置为IC的产量为空
Else
m = d(st)
brr(m, 9) = brr(m, 9) & " " & arr(i, 9) '汇总假焊的所有不良位置
brr(m, 10) = brr(m, 10) + arr(i, 10) '同种不良类型的不良数量之和
End If
Next
Worksheets.Add.Name = "第一题答案-" & Timer - t
[a1].Resize(UBound(brr), 12) = brr
Columns("A:L").Select
Selection.Columns.AutoFit '自动调整列宽
End Sub

复制代码

Sub 作业三()
'思路：将县区不为空的省市县区连接作为KEY写入字典,再用连接符分割写入数组
Dim arr, brr(1 To 25, 1 To 3), d As Dictionary, i As Integer, crr
Set d = New Dictionary
arr = [a1].CurrentRegion
For i = 2 To UBound(arr)
If arr(i, 3) <> "" Then
d(arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3)) = d.Count + 1
crr = Split(d.Keys(d.Count - 1), ",")
brr(d.Count, 1) = crr(0): brr(d.Count, 2) = crr(1): brr(d.Count, 3) = crr(2)
End If
Next
[e2].Resize(d.Count, 3) = brr
End Sub

复制代码

Sub 作业二()
'主要思路：将A列数据连接后写入字典，B列数据连接后如果在字典D中，则放入数组中。
Dim arr, brr, crr(), i As Double, d As New Dictionary, s As String, s2 As String, m As Double, k As Integer
arr = [a1].CurrentRegion
For i = 2 To UBound(arr)
s = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4) & "," & arr(i, 5) & "," & arr(i, 6)
d(s) = d.Count + 1
Next
brr = [h8].CurrentRegion
For i = 2 To UBound(brr)
s2 = brr(i, 1) & "," & brr(i, 2) & "," & brr(i, 3) & "," & brr(i, 4) & "," & brr(i, 5) & "," & brr(i, 6)
If d.Exists(s2) Then
m = m + 1
ReDim Preserve crr(1 To 6, 1 To m) '因只能改变最未位的维位，固先将行列调换下位置，输出时转置下即可
For k = 1 To 6
crr(k, m) = arr(d(s2) + 1, k)
Next
End If
Next
[o7].Resize(m, 6) = WorksheetFunction.Transpose(crr)
End Sub

复制代码

fffox · 发表于 2013-11-26 10:35

作业三，实现三级下拉列表

Option Explicit
Dim arr, i%
Private Sub Worksheet_Change(ByVal Target As Range)
Dim iList1$, iList2$
Dim d1 As New Dictionary
'如果选择的单元格不合要求则退出
If Target.Count > 1 Then Exit Sub
If Target.Row = 1 Or Target.Row > 50 Then Exit Sub
If Target.Column <> 5 And Target.Column <> 6 Then Exit Sub
If Target <> "" Then
If Target.Column = 5 Then '单元格在“省”这一列
For i = 1 To UBound(arr)
If arr(i, 1) = Target.Value Then
d1(arr(i, 2)) = "" '以该省所辖市创建字典
End If
Next
iList1 = Join(d1.Keys, ",") '市名的字符串，用于数据有效性
With Target.Offset(0, 1).Validation '创建右边单元格的数据有效性
.Delete
.Add Type:=xlValidateList, Formula1:=iList1
End With
Target.Offset(0, 1) = "" '右边的单元格清空，方便正确输入
Else '单元格在“市”这一列
For i = 1 To UBound(arr)
If arr(i, 2) = Target.Value And arr(i, 1) = Target.Offset(0, -1).Value Then
d1(arr(i, 3)) = "" '以所辖县区名为关键字创建字典
End If
Next
iList2 = Join(d1.Keys, ",")
With Target.Offset(0, 1).Validation '设置县区单元格的数据有效性
.Delete
.Add Type:=xlValidateList, Formula1:=iList2
End With
Target.Offset(0, 1) = ""
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim d As New Dictionary
Dim iList$
'如果点选的单元格不合要求则退出循环
If Target.Count > 1 Then Exit Sub
If Target.Column <> 5 Then Exit Sub
If Target.Row = 1 Or Target.Row > 50 Then Exit Sub
'读入源数据到arr数组
arr = Range("a2:c" & Cells(Rows.Count, 1).End(xlUp).Row)
For i = 1 To UBound(arr)
d(arr(i, 1)) = "" '以省名为关键字创建字典
Next
iList = Join(d.Keys, ",")
'把不重复省名保存为字符串，用于数据有效性
With Target.Validation '创建有数据有效性
.Delete
.Add Type:=xlValidateList, Formula1:=iList
End With
Target.Offset(0, 1).Resize(1, 2) = ""
End Sub

复制代码

ly258 · 发表于 2013-11-26 13:35

Sub 作业1()
Dim D As New Dictionary
Dim d1 As New Dictionary
Dim d2 As New Dictionary
Dim i, j, t, arr, arr1
arr = Range("a1:l" & Cells(Rows.Count, 1).End(3).Row)
D(arr(1, 1) & arr(1, 2) & arr(1, 5) & arr(1, 8)) = 1
For i = 2 To UBound(arr)
D(arr(i, 1) & arr(i, 2) & arr(i, 5) & arr(i, 8)) = i '用字典D.ITEM记录唯一值在ARR数组中的行数
d1(arr(i, 1) & arr(i, 2) & arr(i, 5) & arr(i, 8)) = d1.Item(arr(i, 1) & arr(i, 2) & arr(i, 5) & arr(i, 8)) & " " & arr(i, 9) '不良位置按条件进行连接的值放到字典d1中
d2(arr(i, 1) & arr(i, 2) & arr(i, 5) & arr(i, 8)) = d2.Item(arr(i, 1) & arr(i, 2) & arr(i, 5) & arr(i, 8)) + arr(i, 10) '不良数据累加放到字典d2中
Next i
ReDim arr1(1 To D.Count, 1 To UBound(arr, 2))
t = 1
For Each i In D.Items
For j = 1 To UBound(arr1, 2)
arr1(t, j) = arr(i, j) '把D.ITEM所记录的数据放到ARR1中
Next j
If t <> 1 Then
arr1(t, 9) = Mid(d1.Item(arr1(t, 1) & arr1(t, 2) & arr1(t, 5) & arr1(t, 8)), 2) '同条件的不良位置用D1中的值替换
arr1(t, 10) = d2.Item(arr1(t, 1) & arr1(t, 2) & arr1(t, 5) & arr1(t, 8)) '同条件的不良数量用D2中的值替换
End If
If arr1(t, 9) = "IC" Then arr1(t, 12) = "" '不良位置=CI的产量为空
t = t + 1
Next i
Sheets("效果一").Range("a1").Resize(Rows.Count, Columns.Count).Clear
Sheets("效果一").Range("a1").Resize(UBound(arr1, 1), UBound(arr1, 2)) = arr1
End Sub
Sub 作业2()
Dim D As New Dictionary
Dim arr, arr1, arr2, i, j, t, s
arr = Range("A2:f40000")
arr1 = Range("h2:m40000")
ReDim arr2(1 To 40000, 1 To 6)
For i = 1 To UBound(arr1)
D(arr1(i, 1) & arr1(i, 2) & arr1(i, 3) & arr1(i, 4) & arr1(i, 5) & arr1(i, 6)) = "" '用B组数据建立字典
Next i
t = 1
For i = 1 To UBound(arr)
If D.Exists(arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6)) Then
For j = 1 To UBound(arr, 2)
arr2(t, j) = arr(i, j) '相同条件下,A组数据在字典D中能找到,把对应A组数据放到数组ARR2中
Next j
t = t + 1
End If
Next i
Range("o2").Resize(t, UBound(arr2, 2)) = arr2
End Sub
Sub 作业3()
Dim D As New Dictionary
Dim arr, arr1, i, t, s
arr = Range("a2:c25")
For i = 1 To UBound(arr)
If arr(i, 3) <> "" Then
D(arr(i, 1) & arr(i, 2) & arr(i, 3)) = i '用省+市+县区建立字典D,ITEM记录数组ARR中的行数
End If
Next i
ReDim arr1(1 To D.Count, 1 To 3) '用D.COUNT重新定义数组长度
t = 1
For Each i In D.Items
For s = 1 To 3
arr1(t, s) = arr(i, s) '在ARR数组中,以ITEM所记录值的对应数据,放到数组ARR1中,
Next s
t = t + 1
Next i
Range("e2").Resize(UBound(arr1, 1), UBound(arr1, 2)) = arr1
With ActiveWorkbook.Worksheets("作业三").Sort '排序
.SetRange Range("E1:G12")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

复制代码

阿呆88 · 发表于 2013-11-27 10:10

Sub 作业二()
Dim arr, brr, crr(), i As Double, d As New Dictionary, s As String, s2 As String, l As Double, o As Integer
arr = [a1].CurrentRegion
For i = 2 To UBound(arr)
s = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4) & "," & arr(i, 5) & "," & arr(i, 6)
d(s) = d.Count + 1
Next
brr = [h8].CurrentRegion
For i = 2 To UBound(brr)
s2 = brr(i, 1) & "," & brr(i, 2) & "," & brr(i, 3) & "," & brr(i, 4) & "," & brr(i, 5) & "," & brr(i, 6)
If d.Exists(s2) Then
l = l + 1
ReDim Preserve crr(1 To 6, 1 To l)
For o = 1 To 6
crr(k, m) = arr(d(s2) + 1, o)
Next
End If
Next
[o7].Resize(m, 6) = WorksheetFunction.Transpose(crr)
End Sub

复制代码

联乔 · 发表于 2013-11-27 14:56

Sub homework1()
Dim dic As New Dictionary
Dim lrow As Long '总行数
Dim x&, y%
Dim str As String
Dim k%, iRow
Dim arr(1 To 10000, 1 To 12)
Dim hArr
Dim t
t = Timer
With Sheets("源数据一")
hArr = .Range("a1:l1")
lrow = .Range("a" & .Rows.Count).End(3).Row
For x = 2 To lrow
str = ""
For y = 1 To 8
str = str & "|" & .Cells(x, y)
Next y
If dic.Exists(str) Then
iRow = dic(str)
arr(iRow, 9) = arr(iRow, 9) & " " & .Cells(x, 9)
arr(iRow, 10) = arr(iRow, 10) + .Cells(x, 10)
Else
k = k + 1
dic(str) = k
For y = 1 To 11
arr(k, y) = .Cells(x, y)
If .Cells(x, 8) = "假焊" Then arr(k, 12) = .Cells(x, 12)
Next y
End If
Next x
End With
Sheets.Add
With ActiveSheet
.Range("a1").Resize(1, 12) = hArr
.Range("a2").Resize(lrow - 1, 12) = arr
.Name = "第一题答案-" & Timer - t
End With
End Sub

复制代码

Sub homework2()
Dim dic As New Dictionary
Dim arr, brr, crr(1 To 100000, 1 To 6)
Dim k As Long
Dim x As Long
Dim str As String
arr = Range("a2").CurrentRegion
For x = 2 To UBound(arr)
str = ""
For y = 1 To 6
str = str & "|" & arr(x, y)
Next y
dic(str) = ""
Next x
brr = Range("h2").CurrentRegion
For x = 2 To UBound(brr)
str = ""
For y = 1 To 6
str = str & "|" & brr(x, y)
Next y
If dic.Exists(str) Then
k = k + 1
For y = 1 To 6
crr(k, y) = brr(x, y)
Next y
End If
Next x
Range("o2").Resize(k, 6) = crr
End Sub

复制代码

Sub homework3()
Dim dic As New Dictionary, dic1 As New Dictionary
Dim x%, y%, k%
Dim arr(1 To 100, 1 To 3), brr
brr = Range("a2:c25")
For x = 1 To 24
If brr(x, 1) = "湖北" Then
dic(brr(x, 2)) = brr(x, 2)
End If
Next x
For y = 0 To dic.Count - 1
For x = 1 To 24
If brr(x, 2) = dic.Items(y) Then
If Not dic1.Exists(brr(x, 3)) Then
k = k + 1
arr(k, 1) = brr(x, 1): arr(k, 2) = brr(x, 2): arr(k, 3) = brr(x, 3)
dic1(brr(x, 3)) = ""
End If
End If
Next x
Next y
Range("e2").Resize(k, 3) = arr
End Sub

复制代码

xhrys · 发表于 2013-11-27 15:47

本帖最后由 xhrys 于 2013-11-28 12:34 编辑

在外地出差，没时间听课做作业，勉强做了一题，越来越跟不上讲课的进度了……

附件上传不上去

Sub 作业二()
Dim arr1, arr2, arr3(1 To 10000)
Dim d1 As New Dictionary
Dim d2 As New Dictionary
Dim i As Long
Dim j As Long, k As Long
arr1 = Range("a2:f" & Cells(Rows.Count, "a").End(xlUp).Row).Value
arr2 = Range("h2:m" & Cells(Rows.Count, "a").End(xlUp).Row).Value
For i = 1 To UBound(arr1, 1)
d1(arr1(i, 1) & "-" & arr1(i, 2) & "-" & arr1(i, 3) & "-" & arr1(i, 4) & "-" & arr1(i, 5) & "-" & arr1(i, 6)) = ""
Next
For i = 1 To UBound(arr2, 1)
If d1.Exists(arr2(i, 1) & "-" & arr2(i, 2) & "-" & arr2(i, 3) & "-" & arr2(i, 4) & "-" & arr2(i, 5) & "-" & arr2(i, 6)) Then
d2(arr2(i, 1) & "-" & arr2(i, 2) & "-" & arr2(i, 3) & "-" & arr2(i, 4) & "-" & arr2(i, 5) & "-" & arr2(i, 6)) = ""
End If
Next
Range("o2:t65536").ClearContents
Range("v1").Resize(d2.Count) = WorksheetFunction.Transpose(d2.Keys)
j = Range("v1").End(xlDown).Row
For k = 1 To j
arr3(k) = Split(Cells(k, "v").Value, "-") 'CInt为什么不起作用？
Range("o" & k + 1 & ":t" & k + 1) = arr3(k)
Next
Columns("v").ClearContents
Range("V1").Select
Application.CutCopyMode = False
Selection.Copy
Range("O2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:= _
False, Transpose:=False
End Sub

复制代码

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

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

相关帖子

点评

评分

点评

评分

点评

评分

点评

评分

评分

点评

评分

点评

点评

评分

点评

评分