第8讲示例: VBA数组处理重复值

zjxia889 · 发表于 2008-1-9 21:14

Sub 一有二无() Range("E2:E20").ClearContents Dim arr1, arr2, k%, l%, arr3(1 To 10) arr1 = Application.Transpose(Range("a2:A11")) arr2 = Application.Transpose(Range("B2:B11")) For k = LBound(arr1) To UBound(arr1)  ss = Filter(arr2, arr1(k))   If UBound(ss) = -1 Then     l = l + 1     arr3(l) = arr1(k)    End If Next k Range("E2").Resize(UBound(arr3)) = Application.Transpose(arr3) End Sub

cn12345678 · 发表于 2008-1-9 21:35

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 21:47:03编辑过]

燕子11 · 发表于 2008-1-9 21:35

[em01]

wayy · 发表于 2008-1-9 21:38

学习一下。

红岩铺 · 发表于 2008-1-9 22:59

Sub 唯一值循环法() if [d2]="" then 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第一句不加判断,就会在开始执行是时清除D2的标题

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

Sub 唯一的编号() Range("d2:d23") = "" Dim mrg As Range, arr(), arr1(), x%, m%, t%, n% 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先把两列合成一列再去重复

菁菁 · 发表于 2008-1-10 10:44

<div class="msgheader">QUOTE:</div><div class="msgborder">以下是引用lpz001在2008-1-9 20:02:00的发言： 来啦！</div>

bbwsj · 发表于 2008-1-10 10:58

Sub 唯一编号普通()   Dim z%, x%, y%   z = 2   For y = 1 To 2     x = Cells(65536, y).End(xlUp).Row     Range(Cells(2, y), Cells(x, y)).Copy Range("d" & z)     z = [d65536].End(xlUp).Row + 1   Next     Range("d2:d" & z).AdvancedFilter Action:=xlFilterInPlace, Unique:=True End SubSub 唯一编号数组()     Dim arr1, arr2, arr3(), z%, x%, y%   arr1 = Range("a2:a11")   arr2 = Range("b2:b11")   ReDim Preserve arr3(1 To 20, 1 To 1)   For z = 1 To 10     arr3(z, 1) = arr1(z, 1)   Next   z = z - 1   For y = 1 To 10     For x = 1 To 10     If arr2(y, 1) = arr1(x, 1) Then GoTo 100     Next     z = z + 1   arr3(z, 1) = arr2(y, 1) 100   Next  Range("d2").Resize(20, 1) = arr3 End Sub Sub 唯一编号字典()   Dim d As New Dictionary   Dim arr1, arr2, x%, y%   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) End Sub Sub 物品1有物品2没有()   Dim arr1, arr2, z%, x%, y%   arr1 = Range("a2:a11")   arr2 = Range("b2:b11")   For y = 1 To 10     For x = 1 To 10     z = [e65536].End(xlUp).Row + 1     If arr1(y, 1) = arr2(x, 1) Then GoTo 100     Next     Range("e" & z) = arr1(y, 1) 100   Next End Sub

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

minant · 发表于 2008-1-10 16:18

这次的收获真大，以前从未使用过字典，不知道会不会用[em01][em01][em01]

红岩铺 · 发表于 2008-1-20 20:20

同学们好,老师辛苦了

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

[习题] 第8讲示例: VBA数组处理重复值

filter把A1找到A10，A11当成找到?

浏览过的版块