VBA第8讲作业答案上传贴

windtear20 · 发表于 2008-1-14 22:07

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

[此贴子已经被作者于2008-1-14 22:09:13编辑过]

Leil · 发表于 2008-1-15 18:09

Sub 商品A有() Dim arr1, arr2, arr3, x As Integer, y As Integer arr1 = Range("a2:a11") arr2 = Range("b2:b11") ReDim arr3(1 To UBound(arr2) + 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 200 Next y k = k + 1 arr3(k, 1) = arr1(x, 1) 200: Next x Range("e2").Resize(k, 1) = arr3 End Sub Sub 商品B有() Dim arr1, arr2, arr3, x As Integer, y As Integer arr1 = Range("a2:a11") arr2 = Range("b2:b11") ReDim arr3(1 To UBound(arr2) + 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 200 Next y k = k + 1 arr3(k, 1) = arr2(x, 1) 200: Next x Range("f2").Resize(k, 1) = arr3 End Sub

akabuta · 发表于 2008-1-15 18:52

Sub 唯一的编号() Range("d2:d" & Range("d65536").End(xlUp).Row) = "" Dim arr1, arr2, arr3() 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 x 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(x + k - 1, 1) = arr2(z, 1) 100: Next z Range("d2").Resize(k + x) = arr3 End Sub Sub 物品1有物品2没有() 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   k = k + 1 arr3(k, 1) = arr1(x, 1) 100: Next Range("e2").Resize(k, 1) = arr3 End Sub Sub 物品2有物品1没有() 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 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

leolee82 · 发表于 2008-1-15 18:57

没全用数组，速度慢点。3问都放到一起了Sub dddd() t = Timer Range("d2:f22").ClearContents Dim arr1 Dim arr2 Dim cell1 As Range, cell2 As Range, cell3 As Range Set cell1 = [d12] Set cell2 = [e2] Set cell3 = [f2] arr1 = Range("a2:a11")  arr2 = Range("b2:b11") For i = 1 To 10     For j = 1 To 10         If arr1(i, 1) = arr2(j, 1) Then k = k + 1         If arr2(i, 1) = arr1(j, 1) Then m = m + 1     Next     Cells(i + 1, 4) = arr1(i, 1)     If k = 0 Then cell2 = arr1(i, 1):  Set cell2 = cell2.Offset(1, 0)     If m = 0 Then cell3 = arr2(i, 1):   Set cell3 = cell3.Offset(1, 0)     If m = 0 Then cell1 = arr2(i, 1):   Set cell1 = cell1.Offset(1, 0)     m = 0     k = 0 Next MsgBox Timer - t End Sub

hxd123 · 发表于 2008-1-15 20:04

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

zhao08681 · 发表于 2008-1-15 23:59

Sub 物品1有物品2没有()   Dim arr1, arr2, arr3   Dim a, b, m   m = 1      arr1 = Range("a2:a11")      arr2 = Range("b2:b11")      ReDim arr3(1 To UBound(arr1) + UBound(arr2), 1 To 1)  For a = 1 To UBound(arr1)    For b = 1 To UBound(arr2)       If arr1(a, 1) = arr2(b, 1) Then         GoTo 100       End If     Next b     arr3(m, 1) = arr1(a, 1)     m = m + 1 100:   Next a   Range("E2").Resize(a) = arr3 End Sub Sub 物品2有物品1没有()   Dim arr1, arr2, arr3   Dim a, b, m   m = 1      arr1 = Range("b2:b11")      arr2 = Range("a2:a11")      ReDim arr3(1 To UBound(arr1) + UBound(arr2), 1 To 1)  For a = 1 To UBound(arr1)    For b = 1 To UBound(arr2)       If arr1(a, 1) = arr2(b, 1) Then         GoTo 100       End If     Next b     arr3(m, 1) = arr1(a, 1)     m = m + 1 100:   Next a   Range("F2").Resize(a) = arr3 End Sub

为工作 · 发表于 2008-1-16 00:27

Sub 一有二没有()  Dim arr1, arr2, arr3(), x as Integer , y as Integer, 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 二有一没有() Dim arr1, arr2, arr3(), x as Integer, y as Integer, 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

producer · 发表于 2008-1-16 08:30

Sub 物品有_1()  Dim dic As New Dictionary  Dim arr1, arr2  arr1 = Range("a2:a11")  arr2 = Range("b2:b11")   For x = 1 To UBound(arr1)    dic(arr1(x, 1)) = ""   Next x   For y = 1 To UBound(arr2)    If dic.Exists(arr2(y, 1)) Then dic.Remove (arr2(y, 1))   Next y   Range("e2").Resize(dic.Count) = Application.Transpose(dic.Keys) End SubSub 物品有_2()  Dim dic As New Dictionary  Dim arr1, arr2  arr1 = Range("a2:a11")  arr2 = Range("b2:b11")  For x = 1 To UBound(arr2)   dic(arr2(x, 1)) = ""  Next x  For y = 1 To UBound(arr1)   If dic.Exists(arr1(y, 1)) Then dic.Remove (arr1(y, 1))  Next y  Range("f2").Resize(dic.Count) = Application.Transpose(dic.Keys) End Sub

wayy · 发表于 2008-1-16 09:11

只有好好学习一下，还没有记住其中的格式。

pp8597 · 发表于 2008-1-16 10:49

Sub 一有二没有()  Dim arr1, arr2, arr3(), x%, y%, k%  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 二有一没有() Dim arr1, arr2, arr3(), x%, y%, k% 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

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

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

唉，真有点跟不上了啊