VBA第8讲作业答案上传贴

不看不看 · 发表于 2008-1-10 00:30

Sub 唯一的编号() Range("d2:d23") = "" Dim mrg As Range, arr(), arr1(), x%, m%, t%, n%，k% ReDim arr(1 To 22, 1 To 1) For Each mrg In Range("a2:b11") If mrg <> "" Then k = k + 1 arr(k, 1) = mrg End If Next mrg ReDim arr1(1 To 22, 1 To 1) t = 1 For m = 1 To 22 For x = 2 + t - 1 To 22 If arr(x, 1) = arr(t, 1) Then arr(x, 1) = "" End If Next x If arr(t, 1) <> "" Then n = n + 1 arr1(n, 1) = arr(t, 1) End If t = t + 1 Next m Range("d2:d23") = arr1 End Sub先把两列合成一列再去重复数据都是看着写上去的 Resize也没用只是为了探讨方法

[此贴子已经被作者于2008-1-10 0:34:29编辑过]

suye1010 · 发表于 2008-1-10 00:50

Sub unique() Dim arr1, arr2, arr3(), i%, j%, k%,x% arr1 = Range("a2:a11") arr2 = Range("b2:b11") Range("d2:d65536").ClearContents ReDim arr3(1 To UBound(arr1) + UBound(arr2), 1 To 1) For x = 1 To UBound(arr1)   arr3(x, 1) = arr1(x, 1) Next x For i = 1 To UBound(arr2)   For j = 1 To UBound(arr1)     If arr2(i, 1) = arr3(j, 1) Then GoTo 100   Next j  k = k + 1  arr3(x + k - 1, 1) = arr2(i, 1)100: Next i Range("D2").Resize(x + k, 1) = arr3 End Sub Sub 物1减2() Dim arr1, arr2, arr3(), i%, j%, x% arr1 = Range("a2:a11") arr2 = Range("b2:b11") Range("E2:E65536").ClearContents ReDim arr3(1 To UBound(arr1) + UBound(arr2), 1 To 1) For x = 1 To UBound(arr1)   arr3(x, 1) = arr1(x, 1) Next x For i = 1 To UBound(arr1)   For j = 1 To UBound(arr2)       If arr2(j, 1) = arr3(i, 1) Then       arr3(i, 1) = ""       End If   Next j Next i Range("E2").Resize(x, 1) = arr3 End Sub Sub 物2减1() Dim arr1, arr2, arr3(), i%, j%, k% arr1 = Range("a2:a11") arr2 = Range("b2:b11") Range("F2:F65536").ClearContents ReDim arr3(1 To UBound(arr1) + UBound(arr2), 1 To 1) For i = 1 To UBound(arr2)   For j = 1 To UBound(arr1)       If arr2(i, 1) = arr1(j, 1) Then GoTo 100   Next j   k = k + 1   arr3(k, 1) = arr2(i, 1) 100: Next i Range("F2").Resize(k, 1) = arr3 End Sub

[此贴子已经被作者于2008-1-10 0:53:39编辑过]

guideming · 发表于 2008-1-10 01:01

Sub 物品1有物品2没有g() Dim arr1, arr2, arr3(), x%, y%, i1%, i2%, k% Range("E2:E" & Range("E2").End(xlDown).Row) = "" arr1 = Range("a2:a11") arr2 = Range("b2:b11") i1 = UBound(arr1) i2 = UBound(arr2) ReDim arr3(1 To i1 + i2, 1 To 1) For x = 1 To UBound(arr1)   For y = 1 To UBound(arr2)    If arr1(x, 1) = arr2(y, 1) Then GoTo 100 Next   k = k + 1   arr3(k, 1) = arr1(x, 1) 100: Next Range("e2").Resize(k, 1) = arr3 End Sub Sub 物品2有物品1没有g() Dim arr1, arr2, arr3(), x%, y%, i1%, i2%, k% Range("f2:f" & Range("f2").End(xlDown).Row) = "" arr1 = Range("a2:a11") arr2 = Range("b2:b11") i1 = UBound(arr1) i2 = UBound(arr2) ReDim arr3(1 To i1 + i2, 1 To 1) For y = 1 To UBound(arr2)   For x = 1 To UBound(arr1)    If arr2(y, 1) = arr1(x, 1) Then GoTo 100 Next x   k = k + 1   arr3(k, 1) = arr2(y, 1) 100: Next y Range("f2").Resize(k, 1) = arr3 End Sub

至尊宝_98_76 · 发表于 2008-1-10 10:33

'物品一有二没有Sub yy1()   Dim d As New Dictionary, x, c, y   c = Range("a2:b11")   y = UBound(c, 1)   Range("e2:e" & y) = ""   For x = 1 To y       d(c(x, 1)) = ""   Next   For x = 1 To y       If d.Exists(c(x, 2)) Then d.Remove (c(x, 2))   Next   Range("e2").Resize(d.Count) = Application.Transpose(d.Keys) End Sub '物品二有一没有Sub yy2()   Dim d As New Dictionary, x, c, y   c = Range("a2:b11")   y = UBound(c, 1)   Range("f2:f" & y) = ""   For x = 1 To y       d(c(x, 2)) = ""   Next   For x = 1 To y       If d.Exists(c(x, 1)) Then d.Remove (c(x, 1))   Next   Range("f2").Resize(d.Count) = Application.Transpose(d.Keys) End Sub

[此贴子已经被作者于2008-1-10 10:35:49编辑过]

猫 · 发表于 2008-1-10 11:55

Sub 物品1有物品2没有() Dim arr1, arr2, arr3() Dim x, y, z, k Range("E2:E" & Range("E65536").End(xlUp).Row) = "" arr1 = Range("A2:A11") arr2 = Range("B2:B11") ReDim arr3(1 To UBound(arr1) * UBound(arr2), 1 To 1) For x = 1 To UBound(arr1)    For y = 1 To UBound(arr2)    If arr1(x, 1) = arr2(y, 1) Then GoTo 100    Next y    k = k + 1    arr3(k, 1) = arr1(x, 1) 100: Next x Range("E2").Resize(k, 1) = arr3 End Sub Sub 物品2有物品1没有() Dim arr1, arr2, arr3() Dim x, y, z, k Range("F2:F" & Range("E65536").End(xlUp).Row) = "" arr1 = Range("A2:A11") arr2 = Range("B2:B11") ReDim arr3(1 To UBound(arr1) * UBound(arr2), 1 To 1) For x = 1 To UBound(arr2)    For y = 1 To UBound(arr1)    If arr1(y, 1) = arr2(x, 1) Then GoTo 100    Next y    k = k + 1    arr3(k, 1) = arr2(x, 1) 100: Next x Range("F2").Resize(k, 1) = arr3 End Sub

[此贴子已经被作者于2008-1-10 21:48:02编辑过]

hncd · 发表于 2008-1-10 12:31

Sub aaaa2() Dim arr1, arr2, arr3() Range("f2:f" & Range("d65536").End(xlUp).Row) = "" arr1 = Range("a2:a11") arr2 = Range("b2:b11") ReDim arr3(1 To UBound(arr1) + UBound(arr2), 1 To 1) For z = 1 To UBound(arr2) 燜or y = 1 To UBound(arr1) ?If arr2(z, 1) = arr1(y, 1) Then GoTo 100 燦ext y 爇 = k + 1 燼rr3(k, 1) = arr2(z, 1) 100: 燦ext z 燫ange("f2").Resize(k) = arr3 End Sub Sub aaaa1() Dim arr1, arr2, arr3() Range("e2:e" & Range("d65536").End(xlUp).Row) = "" arr1 = Range("a2:a11") arr2 = Range("b2:b11") ReDim arr3(1 To UBound(arr1) + UBound(arr2), 1 To 1) For z = 1 To UBound(arr1) 燜or y = 1 To UBound(arr2) ?If arr1(z, 1) = arr2(y, 1) Then GoTo 100 燦ext y 爇 = k + 1 燼rr3(k, 1) = arr1(z, 1) 100: 燦ext z 燫ange("e2").Resize(k) = arr3 End Sub

hhzjxss · 发表于 2008-1-10 12:32

Sub 提取_唯一值() '循环法---雨中漫步     Dim i%, j%, k%, w%, q%, n%, m%, x%, y%, Z%     Dim arrA, arrB, arr1(), arr2(), arr3()     Dim t     t = Timer     Range("D2:F" & Range("D65536").End(xlUp).Row + 1).ClearContents '加1防止清空以后再清空会造成标题删除，所以多选一行！     x = Range("A1").CurrentRegion.Rows.Count     arrA = Range("A2:A" & x)     arrB = Range("B2:B" & x)     ReDim arr1(1 To UBound(arrA) + UBound(arrB), 1 To 1)     ReDim arr2(1 To UBound(arrA), 1 To 1)     ReDim arr3(1 To UBound(arrA), 1 To 1)     ''''''''''以下为求不重复值 ' '''---------------------------------------------------------     For x = 1 To UBound(arrA)         arr1(x, 1) = arrA(x, 1) '第一个数组全部装进第三个中     Next x  ''---------------------------------------------------------         For Z = 1 To UBound(arrB) '第二个数组中不重复的才装进第三个中             For y = 1 To UBound(arrA)                 If arrB(Z, 1) = arrA(y, 1) Then GoTo 100             Next y             k = k + 1             arr1(x + k - 1, 1) = arrB(Z, 1) '唯一编号的 100:         Next Z         Range("D2").Resize(k + x) = arr1  '''---------------------------------------------------------         ''''''''''以下为求物品1有物品2没有         For i = 1 To UBound(arrA) '第二个数组中不重复的才装进第三个中             n = 0             For j = 1 To UBound(arrB)                 n = n + 1                 If arrA(i, 1) = arrB(j, 1) Then                     GoTo 200                 ElseIf arrA(i, 1) <> arrB(j, 1) And n = UBound(arrB) Then                     m = m + 1                     arr2(m, 1) = arrA(i, 1)   '唯一编号的                     GoTo 200                 End If             Next j 200:         Next i         Range("E2").Resize(m, 1) = arr2  '''---------------------------------------------------------         ''''''''''以下为求物品2有物品1没有         m = 0         For i = 1 To UBound(arrB) '第二个数组中不重复的才装进第三个中             n = 0             For j = 1 To UBound(arrA)                 n = n + 1                 If arrB(i, 1) = arrA(j, 1) Then                     GoTo 300                 ElseIf arrB(i, 1) <> arrA(j, 1) And n = UBound(arrB) Then                     m = m + 1                     arr3(m, 1) = arrB(i, 1)   '唯一编号的                     GoTo 300                 End If             Next j 300:         Next i         Range("F2").Resize(m, 1) = arr3                 MsgBox "提取成功，用时 " & Timer - t & "秒！", 0 + 64, "雨中漫步提示你：" End Sub

hhzjxss · 发表于 2008-1-10 13:18

取巧用了字典，具体用字典怎么提取重复值，倒是不太清楚！Sub 提取_A不重复值_字典法()     ''此法为取巧，如果不是重复的在最后面，此法不成立！     Dim d As New Dictionary     Dim arr1, arr2, x%, y%     arr1 = Range("a2:a11")     arr2 = Range("b2:b11")     For x = 1 To UBound(arr1)         For y = 1 To UBound(arr2)             If d.Exists(arr2(y, 1)) Then '                Debug.Print arr2(y, 1)                 GoTo 400             Else                 d(arr1(x, 1)) = "" '                Debug.Print arr1(x, 1), arr2(y, 1)             End If         Next y 400:     Next x     Range("E2").Resize(d.Count - 1, 1) = Application.Transpose(d.Keys) End SubSub 提取_B不重复值_字典法()     ''此法为取巧，如果不是重复的在最前面，此法不成立！     Dim d As New Dictionary     Dim arr1, arr2, x%, y%, k%, arr3     arr1 = Range("a2:a11")     arr2 = Range("b2:b11")     ReDim arr3(1 To UBound(arr2), 1 To 1)         For x = UBound(arr2) To 1 Step -1         For y = UBound(arr1) To 1 Step -1             If d.Exists(arr1(y, 1)) Then                 Debug.Print arr1(y, 1)                 GoTo 400             Else                 k = k + 1                 arr3(k, 1) = arr2(x, 1)                 d(arr3(k, 1)) = "" '                Debug.Print k, arr3(k, 1), arr2(x, 1), arr1(y, 1)                 GoTo 400             End If         Next y 400:     Next x     Range("F2").Resize(d.Count - 1, 1) = Application.Transpose(d.Keys)     ''升序排列     Range("F2:F7").Sort Key1:=Range("F2"), Order1:=xlAscending, Header:=xlNo, _         OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _         :=xlPinYin, DataOption1:=xlSortNormal     End Sub

hhzjxss · 发表于 2008-1-10 13:24

原来至尊宝_98_76做了。  Dim d As New Dictionary, x, c, y是不是能够一次可以申明几个字典呀？

zjxia889 · 发表于 2008-1-10 14:36

Sub 唯一1() Dim arr1, arr2, x% Range("D2:D20").ClearContents Dim d As New Dictionary arr1 = Range("A2:a11").Value arr2 = Range("B2:b11").Value For x = 1 To UBound(arr1)  d(arr1(x, 1)) = ""  d(arr2(x, 1)) = "" Next x  Range("d2").Resize(d.Count) = Application.Transpose(d.keys)   Set d = Nothing End Sub Sub 一有二无1() Range("E2:E20").ClearContents Dim arr1, arr2, k%, l%, arr3(1 To 10, 1 To 1) Dim d As New Dictionary arr1 = Range("a2:A11") arr2 = Range("B2:B11") For k = LBound(arr1) To UBound(arr1)   d(arr1(k, 1)) = "" Next k For l = LBound(arr2) To UBound(arr2)   If d.Exists(arr2(l, 1)) Then     d.Remove (arr2(l, 1))   End If Next l Range("E2").Resize(d.Count) = Application.Transpose(d.keys) Set d = Nothing End Sub Sub 二有一无1() Range("F2:F20").ClearContents Dim arr1, arr2, k%, l%, arr3(1 To 10, 1 To 1) Dim d As New Dictionary arr2 = Range("a2:A11") arr1 = Range("B2:B11") For k = LBound(arr1) To UBound(arr1)   d(arr1(k, 1)) = "" Next k For l = LBound(arr2) To UBound(arr2)   If d.Exists(arr2(l, 1)) Then     d.Remove (arr2(l, 1))    End If Next l Range("F2").Resize(d.Count) = Application.Transpose(d.keys) Set d = Nothing End Sub

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

[习题] VBA第8讲作业答案上传贴

后面二题只要前面的赋值改一下就行