VBA第8讲作业答案上传贴

jianzh · 发表于 2008-1-13 18:32

Sub 物品1有物品2没有() Dim arr, arr1, arr2, x As Integer, y As Integer, k As Integer 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) '考虑编号1与编号2物品不一样多 For x = 1 To UBound(arr)     For y = 1 To UBound(arr1)         If arr(x, 1) = arr1(y, 1) Then             GoTo 100         End If     Next y     k = k + 1     arr2(k, 1) = arr(x, 1) 100: Next x Range("E2").Resize(UBound(arr2), 1) = arr2 End Sub Sub 物品2有物品1没有() Dim arr, arr1, arr2, x As Integer, y As Integer, k As Integer 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) '考虑编号1与编号2物品不一样多 For x = 1 To UBound(arr1)     For y = 1 To UBound(arr)         If arr1(x, 1) = arr(y, 1) Then             GoTo 100         End If     Next y     k = k + 1     arr2(k, 1) = arr1(x, 1) 100: Next x Range("F2").Resize(UBound(arr2), 1) = arr2 End Sub

lgy255 · 发表于 2008-1-13 18:38

在大家的帮助下，完成了。 Sub 物品1有物品2没有() Dim arr1, arr2, arr3(), x, y, row1, row2, k, i, t t = Timer Range("e2:e" & Range("d65536").End(xlUp).Row + 1) = "" 此行应加1，否则第一次运行时表头被清空 arr1 = Range("a2:a11") arr2 = Range("b2:b11") row1 = UBound(arr1) row2 = UBound(arr2) ReDim arr3(1 To row1 + row2, 1 To 1)   For x = 1 To row1    For y = 1 To row2     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 MsgBox Timer - t End Sub Sub 物品2有物品1没有() Dim arr1, arr2, arr3(), x, y, row1, row2, k, i, t t = Timer Range("f2:f" & Range("d65536").End(xlUp).Row + 1) = "" 此行应加1，否则第一次运行时表头被清空 arr1 = Range("a2:a11") arr2 = Range("b2:b11") row1 = UBound(arr1) row2 = UBound(arr2) ReDim arr3(1 To row1 + row2, 1 To 1)   For y = 1 To row2    For x = 1 To row1     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 MsgBox Timer - t End Sub

[此贴子已经被作者于2008-1-13 18:40:17编辑过]

秦始皇 · 发表于 2008-1-13 20:02

Sub 唯一值() Dim x, y, z Dim arr1, arr2, arr3 Range("d2:D" & Range("D65536").End(xlUp).Row + 1) = ""arr1 = Range("A2:A11") arr2 = Range("B2:B11") ReDim arr3(1 To UBound(arr1, 1) + UBound(arr2, 1), 1 To 1) For x = 1 To UBound(arr1)     arr3(x, 1) = arr1(x, 1) Next x For z = 1 To UBound(arr2, 1) For y = 1 To UBound(arr1, 1)    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) = arr3End Sub---------------------------------------------------------------------------------------- Sub 物品1有物品2没有() Dim x, y, z Dim arr1, arr2, arr3 Range("E2:E" & Range("E65536").End(xlUp).Row + 1) = ""arr1 = Range("A2:A11") arr2 = Range("B2:B11") ReDim arr3(1 To UBound(arr1, 1), 1 To 1) For x = 1 To UBound(arr1) For y = 1 To UBound(arr2, 1)    If arr2(y, 1) = arr1(x, 1) Then GoTo 100    Next y    k = k + 1         arr3(k, 1) = arr1(x, 1) 100: Next x Range("E2").Resize(k) = arr3End Sub--------------------------------------------------------------------------------------------------Sub 物品2有物品1没有() Dim x, y, z Dim arr1, arr2, arr3 Range("F2:F" & Range("E65536").End(xlUp).Row + 1) = ""arr1 = Range("A2:A11") arr2 = Range("B2:B11") ReDim arr3(1 To UBound(arr2, 1), 1 To 1) For x = 1 To UBound(arr2) For y = 1 To UBound(arr1, 1)    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) = arr3End Sub

[此贴子已经被作者于2008-1-13 21:28:16编辑过]

秦始皇 · 发表于 2008-1-13 20:14

Sub 唯一值字典方法() t = Timer() Range("d2:D" & Range("D65536").End(xlUp).Row + 1) = "" Set d = CreateObject("Scripting.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)) = "" Next x For y = 1 To UBound(arr2)     d(arr2(y, 1)) = "" Next y Range("d2").Resize(d.Count) = Application.Transpose(d.Keys) MsgBox Timer() - t End Sub--------------------------------------------------------------------------------------- Sub 物品1有2无字典方法() t = Timer() Range("E2:E" & Range("D65536").End(xlUp).Row + 1) = "" Set d = CreateObject("Scripting.Dictionary") Dim arr1, arr2, x As Integer arr1 = Range("a2:a11") arr2 = Range("b2:b11") For x = 1 To UBound(arr1) For y = 1 To UBound(arr2, 1)    If arr2(y, 1) = arr1(x, 1) Then GoTo 100    Next y    k = k + 1     d(arr1(x, 1)) = "" 100: Next x Range("E2").Resize(d.Count) = Application.Transpose(d.Keys) MsgBox Timer() - t End Sub-----------------------------------------------------------------------------------------------------------Sub 物品2有1无字典方法() t = Timer() Range("F2:F" & Range("D65536").End(xlUp).Row + 1) = "" Set d = CreateObject("Scripting.Dictionary") Dim arr1, arr2, x As Integer arr1 = Range("a2:a11") arr2 = Range("b2:b11") For x = 1 To UBound(arr2) For y = 1 To UBound(arr1, 1)    If arr1(y, 1) = arr2(x, 1) Then GoTo 100    Next y    k = k + 1     d(arr2(x, 1)) = "" 100: Next x Range("F2").Resize(d.Count) = Application.Transpose(d.Keys) MsgBox Timer() - t End Sub

[此贴子已经被作者于2008-1-13 21:27:19编辑过]

fairy3345 · 发表于 2008-1-13 21:13

Sub b() Dim arr1, arr2, arr3(), x As Integer, y As Integer Range("e2:e" & Range("a65536").End(xlUp).Row) = "" arr1 = Range("a2:a20") arr2 = Range("b2:b20") 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 arr1(z, 1) = arr2(y, 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 SubSub bc() Dim arr1, arr2, arr3(), x As Integer, y As Integer Range("e2:e" & Range("a65536").End(xlUp).Row) = "" arr1 = Range("a2:a20") arr2 = Range("b2:b20") ReDim arr3(1 To UBound(arr1) + UBound(arr2), 1 To 1) For x = 1 To UBound(arr1) arr3(x, 1) = arr2(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(k, 1) = arr2(z, 1) 100: Next z Range("f2").Resize(k, 1) = arr3 End Sub

hy6012 · 发表于 2008-1-13 22:00

Sub 物品1有物品2没有() Dim x%, y%, k% 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 Sub Sub 物品2有物品1没有() Dim x%, y%, k% Dim arr1, arr2, arr3() 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

秦始皇 · 发表于 2008-1-14 17:36

Sub 唯一值() t = Timer() Dim x, y, z Dim arr1, arr2, arr3 Range("d2:D" & Range("D65536").End(xlUp).Row + 1) = "" arr1 = Range("A2:A11") arr2 = Range("B2:B11") ReDim arr3(1 To UBound(arr1) + UBound(arr2)) For x = 1 To UBound(arr1)     arr3(x) = arr1(x, 1) Next x For y = 1 To UBound(arr2, 1) If UBound(Filter(arr3, arr2(y, 1))) < 0 Then         k = k + 1         arr3(x + k - 1) = arr2(y, 1) End If Next y Range("d2").Resize(x + k - 1) = Application.Transpose(arr3) MsgBox Timer() - t End Sub

yss5178 · 发表于 2008-1-14 20:03

11组 yss5178 Sub 唯一值() k = 1 Range("d2:d" & Range("d65536").End(xlUp).Row) = "" For y = 1 To 2  For x = 2 To 11  l = Application.WorksheetFunction.CountIf(Range("a2:b11"), Cells(x, y))  If l = 1 Then  k = k + 1  Cells(k, 4) = Cells(x, y)  End If  Next x  Next y End SubSub 物品1有物品2没有() j = 1 Range("e2:e20") = "" For y = 1 To 2  For x = 2 To 11  l = Application.WorksheetFunction.CountIf(Range("a2:a11"), Cells(x, y))  m = Application.WorksheetFunction.CountIf(Range("b2:b11"), Cells(x, y))  If l >= 1 And m = 0 Then  j = j + 1  Cells(j, 5) = Cells(x, y)  End If  Next x  Next y End Sub Sub 物品2有物品1没有() j = 1 Range("f2:f20") = "" For y = 1 To 2  For x = 2 To 11  l = Application.WorksheetFunction.CountIf(Range("a2:a11"), Cells(x, y))  m = Application.WorksheetFunction.CountIf(Range("b2:b11"), Cells(x, y))  If m >= 1 And l = 0 Then  j = j + 1  Cells(j, 6) = Cells(x, y)  End If  Next x  Next y End Sub

呆妈 · 发表于 2008-1-14 20:33

Sub 物品1有2没有() Dim ARR1, ARR2, ARR3, X%, Y% 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 SubSub 物品2有1没有() Dim ARR1, ARR2, ARR3, X%, Y% ARR1 = Range("A2:A11") ARR2 = Range("B2:B11") ReDim ARR3(X 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) = ARR3End Sub 物品2有1没有：好像有点问题不明，请老师指点。ReDim ARR3(X To UBound(ARR1) + UBound(ARR2), 1 To 1)这句 "X" 的位置放1时A7会上去，换上"X"没A7了，可是，是在F3的位置填入。不明白怎么回事？

yqdfd · 发表于 2008-1-14 21:23

Sub 物品1有物品2没有() Dim arr1, arr2, arr3 arr1 = Range("a2:a11") arr2 = Range("b2:b11") ReDim arr3(1 To UBound(arr1), 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) = arr3End SubSub 物品2有物品1没有() 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 z = 1 To UBound(arr1)          If arr2(y, 1) = arr1(z, 1) Then GoTo 100             Next z          k = k + 1          arr3(k, 1) = arr2(y, 1) 100: Next y Range("f2").Resize(k, 1) = arr3

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

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