VBA第8讲作业答案上传贴

箫风 · 发表于 2008-1-10 15:47

Sub test1() Range("e2:e" & Range("e65536").End(xlUp).Row) = ""  Dim arr1, arr2, arr3()  Dim x, y, k As Integer  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) = arr3 End Sub Sub test2() Range("f2:f" & Range("f65536").End(xlUp).Row) = ""  Dim arr1, arr2, arr3()  Dim x, y, k As Integer  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 arr2(x, 1) = arr1(y, 1) Then GoTo 100    Next y    k = k + 1    arr3(k, 1) = arr2(x, 1) 100:   Next x  Range("f2").Resize(k) = arr3 End Sub其实把取唯一值的改一下就可以实现了吧！

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

木樨 · 发表于 2008-1-10 16:26

Sub 唯一的编号()  Dim x%, y%, arr, arr1(), i%, k%   arr = Range("a2:b" & Range("b65536").End(xlUp).Row)   ReDim arr1(1 To UBound(arr) * 2, 1 To 1)   arr1(1, 1) = arr(1, 1)   k = k + 1    For x = 1 To 2     For y = 1 To UBound(arr)      For i = 1 To k       If arr(y, x) = arr1(i, 1) Then GoTo 100      Next i        k = k + 1        arr1(k, 1) = arr(y, x) 100:     Next y    Next x Range("d2:d" & UBound(arr1) + 1) = arr1 End Sub Sub 物1有物2无() Dim arr, arr1, arr2(), x%, y%, k% arr = Range("a2:a" & Range("a65536").End(xlUp).Row) arr1 = Range("b2:b" & Range("b65536").End(xlUp).Row) ReDim arr2(1 To UBound(arr) + UBound(arr1), 1 To 1) For x = 1 To UBound(arr)  For y = 1 To UBound(arr1)   If arr(x, 1) = arr1(y, 1) Then GoTo 100  Next y   k = k + 1   arr2(k, 1) = arr(x, 1) 100: Next x Range("e2").Resize(k) = arr2 End Sub Sub 物2有物1无() Dim arr1, arr2, arr3(), x%, y%, k%  arr1 = Range("a2:a" & Range("a65536").End(xlUp).Row)  arr2 = Range("b2:b" & Range(b65536).End(xlUp).Row)  ReDim arr3(1 To UBound(arr1) + UBound(arr2), 1 To 1)  For x = 1 To UBound(arr2)   For y = 1 To UBound(arr1)    If arr2(x, 1) = arr1(y, 1) Then GoTo 100    Next y    k = k + 1    arr3(k, 1) = arr2(x, 1) 100: Next x Range("f2").Resize(k) = arr3 End Sub

[此贴子已经被作者于2008-1-10 16:26:30编辑过]

greenzhu · 发表于 2008-1-10 17:18

Sub weiyi() Dim arr1, arr2, arr3 Dim x As Long, y As Long, z As Long, t As Long arr1 = Range("a2:a11") arr2 = Range("b2:b11") ReDim arr3(1 To UBound(arr1) + UBound(arr2), 1 To 1) For t = 1 To UBound(arr1) 燼rr3(t, 1) = arr1(t, 1) Next t For x = 1 To UBound(arr2) ?For y = 1 To UBound(arr1) 牋 If arr2(x, 1) = arr1(y, 1) Then 牋牋 GoTo 100 牋 End If ?Next y ?z = z + 1 ?arr3(t + z - 1, 1) = arr2(x, 1) 100: Next x Range("d2").Resize(x - 1 + z) = arr3 End Sub Sub wp1() Dim arr1, arr2, arr3 Dim x As Long, y As Long, z As Long arr1 = Range("a2:a11") arr2 = Range("b2:b11") ReDim arr3(1 To UBound(arr1), 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 ?z = z + 1 ?arr3(z, 1) = arr1(x, 1) 100: Next x Range("e2").Resize(UBound(arr3), 1) = arr3 End Sub Sub wp2() Dim arr1, arr2, arr3 Dim x As Long, y As Long, z As Long arr1 = Range("a2:a11") arr2 = Range("b2:b11") ReDim arr3(1 To UBound(arr1), 1 To 1) For x = 1 To UBound(arr2) ?For y = 1 To UBound(arr1) 牋?If arr2(x, 1) = arr1(y, 1) Then GoTo 100 ?Next y ?z = z + 1 ?arr3(z, 1) = arr2(x, 1) 100: Next x Range("f2").Resize(UBound(arr3), 1) = arr3 End Sub

jyh197994 · 发表于 2008-1-10 18:03

Sub OKOKOK一有() Dim arr1, arr2, arr3() Range("e2").Resize(Range("e65536").End(xlUp).Row - 1, 1) = "" arr1 = Range("a2:a11") arr2 = Range("b2:b11") ReDim arr3(1 To UBound(arr1), 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 OKOKOK二有() Dim arr1, arr2, arr3() Range("f2").Resize(Range("e65536").End(xlUp).Row - 1, 1) = "" arr1 = Range("a2:a11") arr2 = Range("b2:b11") ReDim arr3(1 To UBound(arr2), 1 To 1) For x = 1 To UBound(arr2)  For y = 1 To UBound(arr1)  If arr2(x, 1) = arr1(y, 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

liyh67 · 发表于 2008-1-10 18:27

Sub 唯一的编号() t = Timer Range("D2:D" & Range("D65536").End(xlUp).Row) = "" Dim arr1(), arr2(), arr3() arr1() = Range("A2:A" & Range("A65536").End(xlUp).Row) arr2() = Range("B2:B" & Range("B65536").End(xlUp).Row) k = 0 ReDim arr3(1 To UBound(arr1) + UBound(arr2), 1 To 1) For i = 1 To UBound(arr1)   arr3(i, 1) = arr1(i, 1) Next For x = 1 To UBound(arr2) For y = 1 To UBound(arr1) If arr1(y, 1) = arr2(x, 1) Then GoTo 100 Next y arr3(i + k, 1) = arr2(x, 1) k = k + 1 100: Next x Range("D2").Resize(i + k - 1, 1) = arr3 MsgBox Timer - t End Sub Sub 物品1有物品2没有()t = Timer Range("E2:E" & Range("E65536").End(xlUp).Row) = "" Dim arr1(), arr2(), arr3() arr1() = Range("A2:A" & Range("A65536").End(xlUp).Row) arr2() = Range("B2:B" & Range("B65536").End(xlUp).Row) k = 1 ReDim arr3(1 To UBound(arr1), 1 To 1) For x = 1 To UBound(arr1) For y = 1 To UBound(arr2) If arr2(y, 1) = arr1(x, 1) Then GoTo 100 Next y arr3(k, 1) = arr1(x, 1) k = k + 1 100: Next x Range("E2").Resize(k - 1, 1) = arr3 MsgBox Timer - t End SubSub 物品2有物品1没有() t = Timer Range("F2:F" & Range("F65536").End(xlUp).Row) = "" Dim arr1(), arr2(), arr3() arr1() = Range("A2:A" & Range("A65536").End(xlUp).Row) arr2() = Range("B2:B" & Range("B65536").End(xlUp).Row) k = 1 ReDim arr3(1 To 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 arr3(k, 1) = arr2(x, 1) k = k + 1 100: Next x Range("F2").Resize(k - 1, 1) = arr3 MsgBox Timer - t End Sub

hong4777 · 发表于 2008-1-10 18:55

Sub 唯一编号()  Dim arr1, arr2, arr3()  Dim x, y, z, k  Range("d2:d65536").ClearContents  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)  arr3(x, 1) = arr1(x, 1)  Next    For y = 1 To UBound(arr2)   For z = 1 To UBound(arr1)    If arr3(z, 1) = arr2(y, 1) Then GoTo 100     Next z    k = k + 1    arr3(k + x - 1, 1) = arr2(y, 1) 100   Next y     Range("d2").Resize(k + x - 1, 1) = arr3 End SubSub 物品2中仅有()   Dim arr1, arr2, arr3()   Dim x, y, z   Range("f2:f65536").ClearContents   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 arr2(x, 1) = arr1(y, 1) Then GoTo 100      Next y      z = z + 1      arr3(z, 1) = arr2(x, 1) 100      Next x           Range("f2").Resize(z, 1) = arr3 End SubSub 物品1中仅有()   Dim arr1, arr2, arr3()   Dim x, y, z   Range("e2:e65536").ClearContents   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      z = z + 1      arr3(z, 1) = arr1(x, 1) 100      Next x           Range("e2").Resize(z, 1) = arr3 End Sub

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

<div class="msgheader">QUOTE:</div><div class="msgborder">以下是引用hhzjxss在2008-1-10 13:24:00的发言： 原来至尊宝_98_76做了。  Dim d As New Dictionary, x, c, y是不是能够一次可以申明几个字典呀？ </div>dim x,y,z,d as New Dictionary 这句定义只有d是字典变量，一次定义多个每个都要加as New Dictionary

liyh67 · 发表于 2008-1-10 19:43

用字典做:Sub dict()  '唯一的编号 t = Timer Range("D2:D" & Range("D65536").End(xlUp).Row) = "" Dim d As New Dictionary Dim arr1, arr2, x As Integer arr1 = Range("A2:A11") arr2 = Range("B2:B11") For x = 1 To UBound(arr1) d(arr1(x, 1)) = x Next For x = 1 To UBound(arr2) d(arr2(x, 1)) = x * 2 Next Range("d1").Resize(d.Count) = Application.Transpose(d.Keys) MsgBox Timer - t End Sub Sub dict2()  '物品2有物品1没有() t = Timer Range("F2:F" & Range("F65536").End(xlUp).Row) = "" Dim d As New Dictionary Dim arr1, arr2, arr3, x As Integer arr1 = Range("A2:A11") arr2 = Range("B2:B11") For x = 1 To UBound(arr1) d(arr1(x, 1)) = x Next ReDim arr3(1 To UBound(arr2), 1 To 1) For x = 1 To UBound(arr2) If Not d.Exists(arr2(x, 1)) Then   k = k + 1   arr3(k, 1) = arr2(x, 1) End If Next Range("F2").Resize(k, 1) = arr3 MsgBox Timer - t End Sub

GB16888 · 发表于 2008-1-10 21:30

Sub 物品1有物品2没有() Range("e2:e65536") = "" Dim arr1, arr2, arr3() arr1 = Range("A2:A11") arr2 = Range("B2:B11") ReDim arr3(1 To UBound(arr1) + UBound(arr2), 1 To 1) For y = 1 To UBound(arr1)   For z = 1 To UBound(arr2)   If arr2(z, 1) = arr1(y, 1) Then GoTo 100   Next z   k = k + 1   arr3(k, 1) = arr1(y, 1) 100: Next y Range("e2").Resize(k, 1) = arr3 End Sub Sub 物品2有物品1没有() Range("f2:f65536") = "" Dim arr1, arr2, arr3() 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)   For y = 1 To UBound(arr1)   If arr2(z, 1) = arr1(y, 1) Then GoTo 100   Next y   k = k + 1   arr3(k, 1) = arr2(z, 1) 100: Next z Range("f2").Resize(k, 1) = arr3 End Sub

zd740624 · 发表于 2008-1-10 22:26

sub ff4() Range("e2:e" & Range("e65536").End(xlUp).Row) = "" Dim arr1, arr2, arr3() arr1 = Range("a2:a11") arr2 = Range("b2:b11") ReDim arr3(1 To UBound(arr1), 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 SubSub ff5() Range("f2:f" & Range("f65536").End(xlUp).Row) = "" Dim arr1, arr2, arr3() arr1 = Range("a2:a11") arr2 = Range("b2:b11") ReDim arr3(1 To UBound(arr2), 1 To 1) For y = 1 To UBound(arr2) For x = 1 To UBound(arr1) If arr1(x, 1) = arr2(y, 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

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

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

浏览过的版块