VBA第8讲作业答案上传贴

兰色幻想 · 发表于 2008-1-9 22:48

把第8讲的示例后两问答案代码跟贴传上来.不用上传附件.        题目链接:http://www.excelpx.com/forum.php?mod=viewthread&tid=35173&extra=&page=1#35173

[此贴子已经被作者于2008-1-9 22:49:06编辑过]

杨副官 · 发表于 2008-1-9 22:50

Sub 唯一的编号() Dim arr1, arr2, arr3(), x As Integer, y As Integer, mrow1 As Integer, mrow2 As Integer, k As Integer, i As Integer, t t = Timer Range("d2:d" & Range("d65536").End(xlUp).Row) = "" arr1 = Range("a2:a11") arr2 = Range("b2:b11") mrow1 = UBound(arr1) mrow2 = UBound(arr2) ReDim arr3(1 To mrow1 + mrow2, 1 To 1) For i = 1 To mrow1  arr3(i, 1) = arr1(i, 1)Next i For y = 1 To mrow2   For x = 1 To mrow1    If arr2(y, 1) = arr1(x, 1) Then GoTo 100 Next x   k = k + 1   arr3(i + k - 1, 1) = arr2(y, 1) 100: Next y Range("d2").Resize(i + k - 1, 1) = arr3  MsgBox Timer - t End Sub Sub 物品1有物品2没有() Dim arr1, arr2, arr3(), x As Integer, y As Integer, mrow1 As Integer, mrow2 As Integer, k As Integer Range("e2:e" & Range("e65536").End(xlUp).Row) = "" arr1 = Range("a2:a11") arr2 = Range("b2:b11") mrow1 = UBound(arr1) mrow2 = UBound(arr2) ReDim arr3(1 To mrow1 + mrow2, 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没有() Dim arr1, arr2, arr3(), x As Integer, y As Integer, mrow1 As Integer, mrow2 As Integer, k As Integer Range("f2:f" & Range("f65536").End(xlUp).Row) = "" arr1 = Range("a2:a11") arr2 = Range("b2:b11") mrow1 = UBound(arr1) mrow2 = UBound(arr2) ReDim arr3(1 To mrow1 + mrow2, 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 SubSub 唯一的编号字典方法() 'Set d = CreateObject("Scripting.Dictionary") Dim d As New Dictionary Dim arr1, arr2, x As Integer, y As Integer, t t = Timer Range("d2:d" & Range("d65536").End(xlUp).Row) = "" arr1 = Range("a2:b11") arr2 = Range("b2:b11") mrow1 = UBound(arr1) mrow2 = UBound(arr2) ReDim arr3(1 To mrow1 + mrow2, 1 To 1) For x = 1 To mrow1   d(arr1(x, 1)) = "" Next x For y = 1 To mrow2   d(arr2(y, 1)) = "" Next y Range("d2").Resize(d.Count, 1) = Application.Transpose(d.Keys) MsgBox Timer - t End Sub

[此贴子已经被作者于2008-1-17 17:36:58编辑过]

baby123456 · 发表于 2008-1-9 22:53

rivate Sub CommandButton1_Click()    '物品2有1没 Dim arr1(), arr2(), arr3(), temp Dim i, r As Integer arr1 = WorksheetFunction.Transpose(Range("a2:a11")) arr2 = WorksheetFunction.Transpose(Range("b2:b11")) For i = 1 To UBound(arr1)     temp = Filter(arr1, arr2(i))     If UBound(temp) = -1 Then         r = r + 1         ReDim Preserve arr3(1 To r)         arr3(r) = arr2(i)     End If Next Range("f2").Resize(r, 1) = WorksheetFunction.Transpose(arr3) End Sub

rivate Sub CommandButton2_Click()   '物品1有2没 Dim arr1(), arr2(), arr3(), temp Dim i, r As Integer arr1 = Application.Transpose(Range("a2:a11")) arr2 = Application.Transpose(Range("b2:b11")) For i = 1 To UBound(arr1)     temp = Filter(arr2, arr1(i))     If UBound(temp) = -1 Then         r = r + 1         ReDim Preserve arr3(1 To r)         arr3(r) = arr1(i)     End If Next Range("E2").Resize(UBound(arr3)) = Application.Transpose(arr3) End Sub

rivate Sub CommandButton3_Click()   '唯一编号 Dim arr1(), arr2(), arr3(), temp Dim i, r As Integer arr1 = WorksheetFunction.Transpose(Range("a2:a11")) arr2 = WorksheetFunction.Transpose(Range("b2:b11")) arr3 = arr1 r = UBound(arr3) For i = 1 To UBound(arr1)     temp = Filter(arr1, arr2(i))     If UBound(temp) = -1 Then         r = r + 1         ReDim Preserve arr3(1 To r)         arr3(r) = arr2(i)     End If Next Range("d2").Resize(r, 1) = WorksheetFunction.Transpose(arr3) End Sub

cn12345678 · 发表于 2008-1-9 23:02

Sub cn()     Dim arr1(), arr2(), arr3(), arr4(), arr5()     t = Timer     Range(Range("D2"), Range("F" & Range("d65536").End(xlUp).Row + 1)).ClearContents     k = 1     l = 1     m = 1     x = Range("a65536").End(xlUp).Row     y = Range("b65536").End(xlUp).Row     arr1 = Range("A2:A" & x)     arr2 = Range("B2:B" & y)     ReDim arr3(1 To UBound(arr1), 1 To 1)     ReDim arr4(1 To UBound(arr2), 1 To 1)     ReDim arr5(1 To UBound(arr2), 1 To 1)     For i = 1 To x - 1         For j = 1 To y - 1             If arr1(i, 1) = arr2(j, 1) Then                 arr5(m, 1) = arr1(i, 1)                 arr1(i, 1) = ""                 arr2(j, 1) = ""                 m = m + 1                 Exit For             End If         Next j     Next i     For i = 1 To x - 1         If arr1(i, 1) <> "" Then             arr3(k, 1) = arr1(i, 1)             k = k + 1         End If         If arr2(i, 1) <> "" Then             arr4(l, 1) = arr2(i, 1)             l = l + 1         End If     Next     Sheet1.Range("D2").Resize(k - 1, 1) = arr3     Sheet1.Range("D2").Offset(k - 1, 0).Resize(m - 1, 1) = arr5     Sheet1.Range("D2").Offset(k + m - 2, 0).Resize(l - 1, 1) = arr4     Sheet1.Range("e2").Resize(k - 1, 1) = arr3     Sheet1.Range("f2").Resize(l - 1, 1) = arr4     MsgBox Timer - t End Sub

[此贴子已经被作者于2008-1-9 23:02:06编辑过]

晓 · 发表于 2008-1-9 23:07

Sub 物品1有() Range("e2:e" & Range("e65536").End(xlUp).Row) = "" Dim arr1, arr2, ar3(), i, y, z, k As Integer arr1 = Range("a2:a" & Range("b65536").End(xlUp).Row) arr2 = Range("b2:b" & Range("b65536").End(xlUp).Row) ReDim arr3(1 To UBound(arr1) + UBound(arr2), 1 To 1) For y = 1 To UBound(arr1)   For z = 1 To UBound(arr2)     If arr1(y, 1) = arr2(z, 1) Then GoTo 100   Next   k = k + 1   arr3(k, 1) = arr1(y, 1) 100:   Next y Range("e2").Resize(k, 1) = arr3 End Sub Sub 物品2有() Range("f2:f" & Range("f65536").End(xlUp).Row) = "" Dim arr1, arr2, ar3(), i, y, z, k As Integer arr1 = Range("a2:a" & Range("b65536").End(xlUp).Row) arr2 = Range("b2:b" & Range("b65536").End(xlUp).Row) ReDim arr3(1 To UBound(arr1) + UBound(arr2), 1 To 1) For y = 1 To UBound(arr2)   For z = 1 To UBound(arr1)     If arr2(y, 1) = arr1(z, 1) Then GoTo 100   Next   k = k + 1   arr3(k, 1) = arr2(y, 1) 100:   Next y Range("f2").Resize(k, 1) = arr3 End Sub

[此贴子已经被作者于2008-1-9 23:12:08编辑过]

wgefyj · 发表于 2008-1-9 23:08

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

lileiserver · 发表于 2008-1-9 23:22

我想学习，请问兰老师在哪里能上课呀。

Lxiaohua · 发表于 2008-1-9 23:30

Sub 物品1有物品2没有() Range("e2:e" & Range("e2").End(xlDown).Row) = "" 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 arr1(x, 1) = arr2(y, 1) Then GoTo 100 Next y Range("E" & Range("E65536").End(xlUp).Row).Offset(1, 0) = arr1(x, 1) 100: Next x End Sub Sub 物品2有物品1没有() Range("f2:f" & Range("f2").End(xlDown).Row) = "" Dim arr1, arr2, y%, x% arr1 = Range("a2:a11") arr2 = Range("b2:b11") For y = 1 To UBound(arr2) For x = 1 To UBound(arr1) If arr2(y, 1) = arr1(x, 1) Then GoTo 100 Next x Range("f" & Range("f65536").End(xlUp).Row).Offset(1, 0) = arr2(y, 1) 100: Next y End Sub

[此贴子已经被作者于2008-1-9 23:34:18编辑过]

laosanjie · 发表于 2008-1-9 23:43

7楼以上的高手动作好快啊！！[em17][em17]我还得好好琢磨琢磨才行！第8题后2问的答案贴在下面:Sub 物品1有2没有() '物品1有物品2没有 Range("e2:e" & Range("e65536").End(xlUp).Row) = ""  Dim arr1, arr2, arr3(), k%, y%, z%  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)       For y = 1 To UBound(arr2)         If arr1(z, 1) = arr2(y, 1) Then GoTo l:       Next y       k = k + 1       arr3(k, 1) = arr1(z, 1) l:     Next z     Range("e2").Resize(k, 1) = arr3 End SubSub 物品2有1没有() '物品2有物品1没有 Range("f2:f" & Range("f65536").End(xlUp).Row) = ""  Dim arr1, arr2, arr3(), k%, y%, z%  arr1 = Range("a2:a11")  arr2 = Range("b2:b11")  ReDim arr3(1 To UBound(arr1) + UBound(arr2), 1 To 1)     For y = 1 To UBound(arr2)       For z = 1 To UBound(arr1)         If arr2(y, 1) = arr1(z, 1) Then GoTo l:       Next z       k = k + 1       arr3(k, 1) = arr2(y, 1) l:     Next y     Range("f2").Resize(k, 1) = arr3 End Sub

[此贴子已经被作者于2008-1-11 14:17:45编辑过]

zgwei050 · 发表于 2008-1-9 23:56

哇，已经这么多人了！VBA入门班2组：zgwei050交作业：Sub 查找唯一() Dim arr1, arr2, arr3() Dim x As Integer, y As Integer, z As Integer, k As Integer         Range("d2:d65536") = ""         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(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(x + k, 1) = arr3 End Sub Sub 物品1有物品2没有() Dim arr1, arr2, arr3() Dim x As Integer, y As Integer, z As Integer, k As Integer         Range("E2:E65536") = ""         arr1 = Range("A2:A" & Range("A65536").End(xlUp).Row)         arr2 = Range("B2:b" & Range("B65536").End(xlUp).Row)     ReDim arr3(1 To UBound(arr1), 1 To 1)         For x = 1 To UBound(arr1)         arr3(x, 1) = arr1(x, 1)     Next x     For z = 1 To UBound(arr1)         For y = 1 To UBound(arr2)             If arr2(y, 1) = arr1(z, 1) Then GoTo 100         Next y                 k = k + 1                 arr3(k, 1) = arr1(z, 1) 100:     Next z     Range("E2").Resize(k, 1) = arr3 End Sub Sub 物品2有物品1没有() Dim arr1, arr2, arr3() Dim x As Integer, y As Integer, z As Integer, k As Integer         Range("F2:F65536") = ""         arr1 = Range("A2:A" & Range("A65536").End(xlUp).Row)         arr2 = Range("B2:b" & Range("B65536").End(xlUp).Row)     ReDim arr3(1 To UBound(arr1), 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 arr1(y, 1) = arr2(z, 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 Sub 物品1有物品2也有() Dim arr1, arr2, arr3() Dim x As Integer, y As Integer, z As Integer, k As Integer         Range("G2:G65536") = ""         arr1 = Range("A2:A" & Range("A65536").End(xlUp).Row)         arr2 = Range("B2:b" & Range("B65536").End(xlUp).Row)     ReDim arr3(1 To UBound(arr1), 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 arr1(y, 1) <> arr2(z, 1) Then GoTo 100                 k = k + 1                 arr3(k, 1) = arr2(z, 1) 100:         Next y     Next z     Range("G2").Resize(k, 1) = arr3 End Sub

TvHYzLHs.rar (10.21 KB, 下载次数: 8)

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

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