ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: lj1226189

[求助] 超难,如何用最快的速度查出15项相同的数据记录!

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2013-5-2 17:17 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 香川群子 于 2013-5-2 19:39 编辑

解释后补:

ReDim drr$(m, 1) '定义存放结果的数组drr
    For i = 2 To m - 1 '遍历比对2 to m-1 (最后一行不需要检查了)
        For l = 2 To nn '遍历最初的nn行 即 总列数-相同列数+1 =20-15+1=6
            '(实际为5行,因为我的实际列数是从第2列开始到第6列)
            r = brr(i, brr(0, l)) 'brr(0, l)为按从小到大排序的对应实际列位置,brr(i, brr(0, l))就是对应实际的行、列交叉位置值(字典关键词)
            For k = 1 To crr(l)(r)(0) '遍历嵌套数组中对应关键词相同的所有行元素
                      'crr(l)为嵌套数组中对应本列,crr(l)(r)为嵌套数组中对应该字典关键词r的对应一维数组x,该数值的(0)元素就是对应数组x的元素个数。
                      '因此crr(l)(r)(0)就是  与被检查的行、列交叉位置对应数值完全相同的所有行的个数。也可以写作ubound(crr(l)(r))
                ii = crr(l)(r)(k) '同样的,ii=crr(l)(r)(k) 表示取得遍历嵌套数组中的每一个行位置
                If ii > i Then '如果该行位置比当前行大就继续,否则退出(因为嵌套数组x中包括所有行位置,需要排除)
                    If InStr(s, " " & ii - 1 & "(") = 0 Then '进一步检查该行位置是否已经被检查为相同个数符合条件而取出,避免重复。
                        '我是在这里就进行排除重复的,而Lee1892改进前的代码是所有计算完成后再进行比较排除。这个是有算法差异的地方。
                        cnt = cnt + 1 '统计比对次数
                        cc = 1 '比对相同列数初始化(我的所有列数都是以1为0处理的。这是为了和原始数据的列位置保持一致。)
                        For jj = 2 To n '遍历检查各列
'                            If brr(ii, jj) - brr(i, jj) Then cc = cc + 1 '数值不同时计数+1
                            If cc = nn Then Exit For 计数值达到界限值(=6)时退出检查
                        Next
                        If cc < nn Then s = s & " " & ii - 1 & "(" & n - cc & ")" '如果检查计数值没超过界限值则符合列数条件可以输出结果
                    End If
                End If
            Next
        Next
        If Len(s) Then drr(kk, 0) = i - 1: drr(kk, 1) = s: s = "": kk = kk + 1 '如果检查结果有满足列数条件的则把结果写入数组drr
'         Application.StatusBar = i & " /Cnt: " & cnt & " /Result: " & kk
    Next
    ss = ss & vbCr & "Compare Check: " & Format(Timer - tms, "0.000s"): tms = Timer
   

最后是输出结果到工作表,以及返回各种信息。

'    Sheet2.[a1].CurrentRegion.Offset(1) = ""
'    Sheet2.[a2].Resize(kk, 2) = drr
'
'    ss = ss & vbCr & "Output:        " & Format(Timer - tms, "0.000s") & vbCr
    ss = ss & vbCr & "Time Total:    " & Format(Timer - tts, "0.000s") & vbCr
    ss = ss & vbCr & "Compare same >= " & n - nn + 1
    ss = ss & vbCr & "Get: " & kk & " / " & cnt & " cnt" & vbCr
    MsgBox ss & vbCr & " - by kagawa -"
   
End Sub

TA的精华主题

TA的得分主题

发表于 2013-5-2 20:00 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
lee1892 发表于 2013-5-2 10:36
在我之前的代码上进行了如下改进,附件::
1、增加了一个arrCompared布尔型数组,二维,直接用数据行行 ...

优化效果明显,值的学习。

TA的精华主题

TA的得分主题

发表于 2013-5-2 20:07 | 显示全部楼层
理论上讲,我的算法也还有很大改进余地以避免重复检查。

不过,由于嵌套数组本身是Variant变量,所以和使用Long变量数组相比较,速度就已经差很多了……

TA的精华主题

TA的得分主题

发表于 2013-5-2 21:06 | 显示全部楼层
嵌套数组处理过程中改用如下代码,即把嵌套中最后一层的数组定义为Long数组,结果计算速度大约提高30%倍,整个代码提速15-20%
这样一来,我的算法已经全面超过Lee1892改进前的算法速度了。

       For k = 1 To r
            y = Split(x(k))
            cc = UBound(y)
            ReDim z&(cc) '此处多用一个Long数组z
            z(0) = cc
            For ii = 1 To cc
                z(ii) = y(ii)
            Next
            x(k) = z '原来用Variant变量数组y的地方,改为使用Long变量数组z → 仅此一个优化提高了很多速度。
        Next

TA的精华主题

TA的得分主题

发表于 2013-5-2 23:07 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
香川群子 发表于 2013-5-2 17:00
第3阶段排序,确定需要检查的前nn列是哪几列。

    brr(0, 2) = 2 'brr数组中0行作为排列列序号位置 相当 ...

刚看完斯诺克~

我算看明白了,这不一回事吗,任选5个至少1个相同,用这个原则进行筛选。
和你之前说的完全不是一样啊。

不过数据没有经过逻辑性很强的整理,写这样的代码估计蛮耗细胞的~

很好,继续想办法提高速度,并尝试用概括性的语言描述思路。

TA的精华主题

TA的得分主题

发表于 2013-5-2 23:42 | 显示全部楼层
lee1892 发表于 2013-5-2 23:07
刚看完斯诺克~

我算看明白了,这不一回事吗,任选5个至少1个相同,用这个原则进行筛选。

参考你的boolean 检查方法,我也对自己的算法进行了优化。
(其实之前我也有检查,但是是用了instr方法只检查已经提取结果的部分,不够完整。)

另外,我的嵌套数组由Variant 改为Long数组了,这也提高了20%左右。

最后的效果很不错,综合效果已经比你的代码速度更快了……

TA的精华主题

TA的得分主题

发表于 2013-5-2 23:45 | 显示全部楼层
上附件。


和你的算法比,我的检查次数还是比较多。
但你需要对提取结果作整理,而这一项工作在结果量大时非常耗费时间。

Data Compare Check-2.rar

369.86 KB, 下载次数: 38

TA的精华主题

TA的得分主题

发表于 2013-5-2 23:48 | 显示全部楼层
我的boolean数组是这样使用的,比你的效率高多了:

For i = 2 To m - 1 '循环检查 2 to m -1 时使用
    ReDim frr(i To m) As Boolean 仅定义 i to m 的一维数组,这样可以节省内存空间
    For l = 2 To nn '然后开始对该 i 行的 2 to nn 各列检查。

呵呵

TA的精华主题

TA的得分主题

发表于 2013-5-2 23:51 | 显示全部楼层
lee1892 发表于 2013-5-2 23:07
刚看完斯诺克~

我算看明白了,这不一回事吗,任选5个至少1个相同,用这个原则进行筛选。

虽然算法思路基本上是一回事,但实现的代码算法差别还是不小……

TA的精华主题

TA的得分主题

发表于 2013-5-3 16:10 | 显示全部楼层
本帖最后由 香川群子 于 2013-5-3 16:14 编辑

改进第3版。 接近极限啦。

我的算法,尤其在需要对比的列数增加时效果显著。


……
Lee1892的改进第2项:
2、在对第5个项目(按所需对比次数升序)检查时,
   如果是未对比过的两行(说明前4个项目不同),
   则检查第6个项目是否相同,否则直接排除

结论是,我的代码可以轻易地做到,并且是这样的效果:
检查第1列时,第1列相同,还没有任何不同的列,因此从余下第2列开始比较,需要比对至少其余有 5列不同
检查第2列时,第2列相同,但第1列已经是不同的了,因此从余下第3列开始比较,只需要比对至少其余有 4列不同即可
检查第3列时,第3列相同,但第1-2列已有2列不同,因此从余下第4列开始比较,只需要比对至少其余有 3列不同即可
检查第4列时,第4列相同,但第1-3列已有3列不同,因此从余下第5列开始比较,只需要比对至少其余有 2列不同即可
检查第5列时,第5列相同,但第1-4列已有4列不同,因此从余下第6列开始比较,只需要比对至少其余有 1列不同即可

比对部分代码是:
         ii = krr(l).Index(r).RowNums(k) '确定待检查行位置
         If ii > i Then '如果待检查行位置大于本行则继续,否则不需要检查
                    If frr(ii) = False Then '如果历史记录为False未检查过则继续,否则不需要重复检查
                        frr(ii) = True  '检查历史记录更新为True
                        cc = l '检查计数器初始化【注意不是从0开始,而是从当前列序号开始】
                        For j = l + 1 To n '从本列的下一列开始检查(列序按从小到大)
                            jj = brr(0, j) '从小到大的列序号转换为数据表中对应实际的列位置
                            If brr(ii, jj) - brr(i, jj) Then cc = cc + 1 '如不同则检查计数器+1
                            If cc > nn Then Exit For '检查计数器>检查目标列数时提前退出
                        Next
                        If cc <= nn Then s = s & " " & ii - 1 & "(" & n - cc + 1 & ")"
                         '不同列数未达到检查目标列数时则该列为相同列可以提取结果了
                    End If
                End If

这样处理以后,比较次数才是最少的。

即,不仅仅针对检查最后1列做优化,而是所有的检查列都做优化处理了。



Data Compare Check-3.zip

424.56 KB, 下载次数: 96

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-15 07:25 , Processed in 0.033043 second(s), 7 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表