[开_101] 词语整理

UNARTHUR

这一题我感觉用collection会更快，只是感觉，一会试验一下：） 另：声明变量的语句不能算行数吧？

[此贴子已经被作者于2006-6-9 10:08:17编辑过]

UNARTHUR

献丑了:)

Dim p&, i&, j&, c&, element, arr, arr1()
Dim h As New Collection
p = [a65536].End(xlUp).Row
arr = Range(Cells(1, 1), Cells(p, 1))
On Error Resume Next
For i = 1 To p
temp = Split(arr(i, 1), ",")
For j = 0 To UBound(temp)
  h.Add temp(j), temp(j)
Next j
Next i
c = h.Count
ReDim arr1(1 To c, 0)
i = 1
For Each element In h
arr1(i, 0) = element
i = i + 1
Next
Range("b1:b" & c) = arr1

代码19行，运行时间在0.6-0.7秒之间

QUOTE:

谦虚。

我的电脑算蜗牛级了。测试结果，UNARTHUR编写的代码速度最快，2.34375秒。

[此贴子已经被山菊花于2006-6-29 19:59:51编辑过]

liuym5936

是要学习了,不太懂

ldy888

学习了UNARTHUR兄集合的用法,做的 用时1秒

用集合筛选不重复值,真是太快了!!!

Private Sub CommandButton1_Click()
t = Timer
Dim col As New Collection
On Error Resume Next
arr = Range("a1:a65536") '目标列转到数组,跑得快
ar = Range("z1:z65536") '随便找个空列,建个数组
For a = 1 To [a65536].End(xlUp).Row
aa = arr(a, 1)
Do While InStr(aa, ",") <> 0 '找"," 找到就分
x = InStr(aa, ",")
col.Add Mid(aa, 1, x - 1), Mid(aa, 1, x - 1) '","之前的加入到集合
aa = Mid(aa, x + 1, Len(aa) - x) '","之后的
Loop
col.Add aa, aa '没有","的加入到集合
Next a
For Each xxx In col '集合转到数组
ar(i + 1, 1) = xxx
i = i + 1
Next
Range("b1:b" & col.Count) = ar
Range("g1") = Timer - t
End Sub

附:不等号的发帖方法 <> & l t ; = < & g t ; = >

[此贴子已经被作者于2006-6-12 1:13:53编辑过]

yigepure

OK！知道上回错在什么地方了。

northwolves

'另类方法（使用无表记录集） 添加引用ADO(Microsoft ActiveX Data Objects 2.X Library)

运行时间：	2.705625
测试时间：	57.046875

Private Sub CommandButton1_Click()
t = Timer
Dim rst As New ADODB.Recordset, arr, i As Long
rst.Fields.Append "word", adVarChar, 30
rst.Open
arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
arr = Split(Join(WorksheetFunction.Transpose(arr), ","), ",")
For i = 0 To UBound(arr)
rst.Find "word='" & arr(i) & "'"
If rst.EOF Then rst.AddNew "word", arr(i)
Next
rst.MoveFirst
Range("b1").CopyFromRecordset rst
rst.Close
Range("g1") = Timer - t
End Sub

northwolves

用含主键的临时表可以省去

rst.Find "word='" & arr(i) & "'"
If rst.EOF Then rst.AddNew "word", arr(i)

的时间，应该会再快些

northwolves

谢山菊花的提醒,代码确实有问题,改成下面这样就行了,不过超慢:

Private Sub CommandButton1_Click()

Dim rst As New ADODB.Recordset, rst2 As New ADODB.Recordset, arr, i As Long
rst.Fields.Append "word", adVarChar, 30
rst.Open
arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
arr = Split(Join(WorksheetFunction.Transpose(arr), ","), ",")
For i = 0 To UBound(arr)
x = rst.RecordCount
rst.Find "[word]='" & arr(i) & "'", , adSearchBackward '<----------add here
If rst.BOF Then rst.AddNew "word", arr(i)
Next
rst.MoveFirst
Range("b1").CopyFromRecordset rst
rst.Close

End Sub

northwolves

这样也行,也是超慢,不过就几行(我一般也是用集合或字典的方式,很快的):

Private Sub CommandButton1_Click()
t = Timer
Dim arr
arr = Split(Join(WorksheetFunction.Transpose(Range("a1:a" & Range("a65536").End(xlUp).Row)), ","), ",")
Range("b1").Resize(UBound(arr, 1) + 1, 1) = WorksheetFunction.Transpose(arr)
Range("b1:b" & Range("B65536").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("c1"), Unique:=True
Columns(2).EntireColumn.Delete
Range("g1") = Timer - t
End Sub

jsxjd

原以为是数组公式,VBA有点简单了