[开_101] 词语整理

山菊花 · 发表于 2006-6-2 15:10

题目内容： A列各单元格中包含一个或几个词语，词语之间用逗号分开。请按要求整理数据： 1、一个单元格存放一个词语； 2、重复的词语保留一个。

lCgmQOB9.rar (301.73 KB, 下载次数: 361) 注：测试时间与运行时间无本质的联系。

[此贴子已经被作者于2006-6-2 17:36:03编辑过]

lrf2003 · 发表于 2006-6-4 00:15

cIp1ye1I.rar (107.96 KB, 下载次数: 98)

题目是做出来了，但速度达不到要求，只好献丑了。

QUOTE:

谢谢。

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

lg_cai · 发表于 2006-6-4 00:49

Option Base 1
Private Sub CommandButton1_Click()
t = Timer
Dim ar(1 to 65536, 1 to 1) ' 原代码： Dim ar(65536,1)
Set d = CreateObject("Scripting.Dictionary")
n = [a1].End(xlDown).Row
arr = Range("a1:a" & n)
j = 1
For i = 1 To n
Do While arr(i, 1) <> ""
b = InStr(arr(i, 1), ",")
If b = 0 Then
  a = arr(i, 1)
  arr(i, 1) = ""
Else
  a = Left(arr(i, 1), b - 1)
arr(i, 1) = Right(arr(i, 1), Len(arr(i, 1)) - b)
End If
If Not d.Exists(a) Then
  d.Add a, ""
  ar(j, 1) = a
  j = j + 1
End If
Loop
Next i
'ar = d.keys              '取得关键字
Range("b1:b" & d.Count) = ar
Range("g1") = Timer - t
End Sub

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

qlz110 · 发表于 2006-6-4 19:45

lg_cai兄真是太厉害！简直是快得不能再快了。[em17][em17][em17][em17][em17][em17]

本来我不想灌水的，实在是忍不住了。

cooloaky · 发表于 2006-6-5 10:05

Attachment is too large to upload. Here are codes.
运行时间：1.140625
测试时间：69.5625

Private Sub CommandButton1_Click()
t = Timer
    Dim ds As Object, i As Long, arr, s As String
    i = Me.Range("a65536").End(xlUp).Row
    arr = Me.Range("a1:a" & i)
    arr = Application.Transpose(arr)
    s = Join(arr, ",")
    arr = Split(s, ",")
    Set ds = CreateObject("scripting.dictionary")
    On Error Resume Next
    For i = LBound(arr) To UBound(arr)
        ds.Add arr(i), i
    Next i
    On Error GoTo 0
    arr = ds.keys
    arr = Application.Transpose(arr)
    Me.Range("b1:b" & UBound(arr)) = arr
Range("g1") = Timer - t
End Sub

QUOTE:

Join用得好。

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

andysky · 发表于 2006-6-5 10:35

lg_cai： Do While arr(i, 1) "" 动行时出现“语法错误”如何处理？

lg_cai · 发表于 2006-6-5 11:00

Do While arr(i, 1) ? "" ? 用不等号代替，发贴时不等号要被过滤掉，没办法

[此贴子已经被作者于2006-6-5 11:04:36编辑过]

qlz110 · 发表于 2006-6-5 11:03

以下是引用[I]andysky[/I]在2006-6-5 10:35:32的发言：[BR]lg_cai： Do While arr(i, 1) "" 动行时出现“语法错误”如何处理？

呵呵，这应该是论坛的问题了。括号后有不等号，但把代码复制上论坛就无法显示出来，这已经是个老问题了。

烟雨任平生 · 发表于 2006-6-5 23:23

cooloaky 的方法好快哦，在我的机器上只要 1.04s.不过dictionary的用法我不熟悉,得好好学习一下.

wclaw · 发表于 2006-6-8 04:14

以下是引用[I]cooloaky[/I]在2006-6-5 10:05:17的发言：[BR]Attachment is too large to upload. Here are codes. 运行时间：1.140625 测试时间：69.5625 Private Sub CommandButton1_Click() t = Timer Dim ds As Object, i As Long, arr, s As String i = Me.Range("a65536").End(xlUp).Row arr = Me.Range("a1:a" & i) arr = Application.Transpose(arr) s = Join(arr, ",") arr = Split(s, ",") Set ds = CreateObject("scripting.dictionary") On Error Resume Next For i = LBound(arr) To UBound(arr) ds.Add arr(i), i Next i On Error GoTo 0 arr = ds.keys arr = Application.Transpose(arr) Me.Range("b1:b" & UBound(arr)) = arr Range("g1") = Timer - t End Sub

Not work in Office 2000 2000 cant transpose more than 5461 items in an array

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

[Excel 程序开发] [开_101] 词语整理