有点难度，关于去除“重复”(已解决)

Zamyi

详细说明在附件中，谢谢帮忙！
数据优化下，剩下20638组数据，盼高手出手！
谢谢大家帮忙，原因是R1 = Application.Index(R, i, 0)的速度问题，试试：Option Base 1
Sub Macro1()
t = Timer
Dim R, R1, Rt(), dic As New Dictionary
With Sheets("数据")
n = .[l65536].End(3).Row
R = .Range("a1:l" & n)
For i = 1 To n
If Not IsCF(R(i, 1), R(i, 2), R(i, 3), R(i, 4), R(i, 5), R(i, 6), R(i, 7), R(i, 8), R(i, 9), R(i, 10), R(i, 11), R(i, 12), dic) Then
  dic(R(i, 1) & " " & R(i, 2) & " " & R(i, 3) & " " & R(i, 4) & " " & R(i, 5) & " " & R(i, 6) & " " & R(i, 7) & " " & R(i, 8) _
  & " " & R(i, 9) & " " & R(i, 10) & " " & R(i, 11) & " " & R(i, 12)) = ""
  End If
  Application.StatusBar = "正在检测..." & "已经运算:" & Round(i / 206.38, 1) & "%。"
  'DoEvents
Next
.[n1].Resize(dic.Count) = Application.Transpose(dic.Keys)
End With
MsgBox Timer - t
Set D = Nothing
Application.StatusBar = ""
End Sub
Public Function IsCF(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, D As Dictionary) As Boolean
IsCF = False
If D.Exists(a1 & " " & a2 & " " & a3 & " " & a4 & " " & a5 & " " & a6 & " " & a7 & " " & a8 _
  & " " & a9 & " " & a10 & " " & a11 & " " & a12) Then IsCF = True: Exit Function
If D.Exists(a3 & " " & a4 & " " & a5 & " " & a6 & " " & a7 & " " & a8 & " " & a9 & " " & a10 _
  & " " & a11 & " " & a12 & " " & a1 & " " & a2) Then IsCF = True: Exit Function
If D.Exists(a5 & " " & a6 & " " & a7 & " " & a8 & " " & a9 & " " & a10 & " " & a11 & " " & a12 _
  & " " & a1 & " " & a2 & " " & a3 & " " & a4) Then IsCF = True: Exit Function
If D.Exists(a7 & " " & a8 & " " & a9 & " " & a10 & " " & a11 & " " & a12 & " " & a1 & " " & a2 _
  & " " & a3 & " " & a4 & " " & a5 & " " & a6) Then IsCF = True: Exit Function
If D.Exists(a9 & " " & a10 & " " & a11 & " " & a12 & " " & a1 & " " & a2 & " " & a3 & " " & a4 _
  & " " & a5 & " " & a6 & " " & a7 & " " & a8) Then IsCF = True: Exit Function
If D.Exists(a11 & " " & a12 & " " & a1 & " " & a2 & " " & a3 & " " & a4 & " " & a5 & " " & a6 _
  & " " & a7 & " " & a8 & " " & a9 & " " & a10) Then IsCF = True: Exit Function

If D.Exists(a1 & " " & a12 & " " & a11 & " " & a10 & " " & a9 & " " & a8 & " " & a7 & " " & a6 _
& " " & a5 & " " & a4 & " " & a3 & " " & a2) Then IsCF = True: Exit Function
If D.Exists(a11 & " " & a10 & " " & a9 & " " & a8 & " " & a7 & " " & a6 & " " & a5 & " " & a4 _
& " " & a3 & " " & a2 & " " & a1 & " " & a12) Then IsCF = True: Exit Function
If D.Exists(a9 & " " & a8 & " " & a7 & " " & a6 & " " & a5 & " " & a4 & " " & a3 & " " & a2 _
& " " & a1 & " " & a12 & " " & a11 & " " & a10) Then IsCF = True: Exit Function
If D.Exists(a7 & " " & a6 & " " & a5 & " " & a4 & " " & a3 & " " & a2 & " " & a1 & " " & a12 _
& " " & a11 & " " & a10 & " " & a9 & " " & a8) Then IsCF = True: Exit Function
If D.Exists(a5 & " " & a4 & " " & a3 & " " & a2 & " " & a1 & " " & a12 & " " & a11 & " " & a10 _
& " " & a9 & " " & a8 & " " & a7 & " " & a6) Then IsCF = True: Exit Function
If D.Exists(a3 & " " & a2 & " " & a1 & " " & a12 & " " & a11 & " " & a10 & " " & a9 & " " & a8 _
& " " & a7 & " " & a6 & " " & a5 & " " & a4) Then IsCF = True: Exit Function
End Function

[ 本帖最后由 Zamyi 于 2009-8-6 19:03 编辑 ]

张三李四

看不懂你的意思，帮不了你。

biaotiger1

即使数组比较的话，几万行。。。。
我还是不试了，期待高手

热浪2006

是真实题目，还是考试题目？！

Zamyi

原帖由 热浪2006 于 2009-8-5 16:14 发表
是真实题目，还是考试题目？！

谢谢关注，不是考试题目。

热浪2006

还是先考虑如何实现，再考虑速度吧。

xyh_bear

用以下代码测试楼主提供的数据38340行12列，只需要140秒左右,，共有8513组数为不重复的

Test.rar (178.06 KB, 下载次数: 17)

2009-8-6 17:17 上传

点击文件名下载附件

1. Sub 行与行的值全部相同则只保留一行()
   
2.     Dim nRowCount As Long
   
3.     Dim DR As Dictionary
   
4.     Dim DelLine As String, TT As String
   
5.    
   
6.     yy = Timer
   
7.     bStop = False
   
8.     nRowCount = Sheet1.Range("a1").CurrentRegion.Rows.Count         
   
9.     Set DR = New Dictionary    '建立一新空白字典对象
   
10.    
    
11.     For i = nRowCount To 1 Step -1    '逆向逐行检查
    
12.         TT = ""
    
13.         
    
14.         For J = 1 To 12            
    
15.             DoEvents    '移交控制权，以免程序运行时，鼠标无法点击工作表中“停止”按钮
    
16.             
    
17.             If bStop = True Then Exit Sub    '如果点了停止按钮，则中断程序
    
18.             
    
19.             TT = TT & "/" & Application.WorksheetFunction.Small(Sheet1.Range(Sheet1.Cells(i, 1), Sheet1.Cells(i, 12)), J)      
    
20.         Next
    
21.         
    
22.         Application.StatusBar = "正在检测 第 " & i & " 行， 最终检查到 1 时就结束程序，请耐心等候。。。（己完成 " & Format(i / nRowCount, "0.0%") & "）" '状态栏提示动态文字。
    
23.         
    
24.         If DR.Exists("k" & TT) = True Then    '如果以 TT 字符串为主键的键存在于字典时，则删除该行
    
25.             If Len(DelLine & "," & i & ":" & i) > 256 Or i = 1 Then  '行号字符满256或检测到最后一行时将删除重复的行
    
26.                 If Len(DelLine) <> 0 Then
    
27.                     DelLine = Right(DelLine, Len(DelLine) - 1)
    
28.                     Range(DelLine).Delete Shift:=xlUp
    
29.                     DelLine = "," & i & ":" & i
    
30.                 Else
    
31.                     Range("1:1").Delete Shift:=xlUp
    
32.                 End If
    
33.             Else
    
34.                 DelLine = DelLine & "," & i & ":" & i
    
35.             End If
    
36.         Else
    
37.             DR.Add "k" & TT, "k" & TT     '如果以 TT 字符串为主键的键不存在于字典时，则添加主键 TT
    
38.         End If
    
39.     Next
    
40.    
    
41.     Application.StatusBar = False  ' 循环完成后，将状态栏文字恢复到默认。
    
42.    
    
43.     MsgBox DR.Count & "用时：" & Timer - yy
    
44. End Sub

复制代码

[ 本帖最后由 xyh_bear 于 2009-8-6 17:17 编辑 ]

Zamyi

原帖由 xyh_bear 于 2009-8-5 17:39 发表
可以实现，但几万行来实际比较，速度可不太理想!

561325

具体代码如下： 状态栏 就有提示当前己运行的情况。


Sub 行与行的值全部相同则只保留一行()
    Dim DR As Dictionary, N As Long, R As Long
...

结果有点问题，算法慢得简直不敢恭维。

xyh_bear

几万行，加上每一行要与其它行都要进行对比，行与行间又要进行12次，速度慢就可想而知了。

不过你为何要这样做？意思何在？在工作当中还没有这个情况吧？

热浪2006

已经按你的算法实现了（在问题表里已验证），为了调试方便未采取删除“重复”而采用了隐藏“重复”的方法。但正如楼上所说的，几万行逐行比对速度慢是必然的！你读入数据还要那么长时间呢！

[ 本帖最后由 热浪2006 于 2009-8-6 10:46 编辑 ]