超难，如何用最快的速度查出15项相同的数据记录！

香川群子

lee1892 发表于 2013-4-25 22:02
我很期待～

36楼改进版附件无法下载，请重新上传。谢谢！

lee1892

香川群子 发表于 2013-5-2 12:55
楼主提供的9586行数据，应该是比较符合实际的数据了。

不管怎么说，我的代码，比全循环比对还是快了不 ...

首先，我还是希望你能够将自己实现方式的逻辑表达清楚，否则别人很难从你的代码里得到什么。像这样的一个例子里，思路（其实就是算法的实质）远比代码本身重要的多。

其次，我所说的实际是针对楼主的需求而言的。楼主所做的事情是在检查数据是真实的测量数据还是人工编造的。而对于水质监测的数据而言，真实的测量数据应该是十分分散的，也就是说除了同一水源水样外，水质指标数值完全一致或多个一致的可能性微乎其微。那么楼主的需要仅仅是有足够理由判定数据是伪造的就可以了，不太会需要改变是15个还是11个项目。而同时，如果是真实的测量数据（应该是可能性较大才对），那么采用我提供的方法会非常快的（不知道你的实现方法是否也是如此）。

另外，考量一种实现方式的好坏，犹为重要的是其功能扩展的难易程度。结合此例，对于水质指标而言，显然对指标值相近的进行分级、分类是常用的手段。那么，我所提供的实现方式和代码结构就会很容易的加以改造实现。

至于变量名的使用习惯，我坚持我的看法，你所采用的简单字母组合的方式是最不可取的。这与水平高低无关。

以上，供参考~

36楼改进版附件无法下载，请重新上传。谢谢！

自测没问题。

香川群子

lee1892 发表于 2013-5-2 13:31
首先，我还是希望你能够将自己实现方式的逻辑表达清楚，否则别人很难从你的代码里得到什么。像这样的一个 ...

我的算法，原始数据差异性越大表现越好。

反之，如果原始数据差异性很小则表现较差。
（如：【臭和味】以及【肉眼可见物】的指标结果只是0、1判断时）
但如果这样差异性小的数据只是个别性的而不是所有19列都这样，
则可以认为完全没有影响。

即，对于15列相同的检查要求，实际只要比对前5列即可，
也就是说，只要前5列有足够的差异性就不会影响速度。

香川群子

lee1892 发表于 2013-5-2 13:31
首先，我还是希望你能够将自己实现方式的逻辑表达清楚，否则别人很难从你的代码里得到什么。像这样的一个 ...

36楼改进版附件无法下载，请重新上传。谢谢！

【自测没问题。】


…………
我这里的问题是：
看到有一个附件的图标，但鼠标靠近后无法出现右键选项。
因此无法进行下载、保存附件的操作。



现在已经可以下载附件了。可能刚才单位里的电脑有问题。

lsdongjh

这题似乎可以换个角度来解决：
１、从１９个项目中抽取１５个进行组合
２、根据每个组合对相关的单元格进行合并
３、用组合的字符串做为字典的key
4、判断字典的item是否>2

不知道这个思路行不行,{:soso_e100:}

香川群子

lee1892 发表于 2013-5-2 13:31
首先，我还是希望你能够将自己实现方式的逻辑表达清楚，否则别人很难从你的代码里得到什么。像这样的一个 ...

【对于水质监测的数据而言，真实的测量数据应该是十分分散的，也就是说除了同一水源水样外，水质指标数值完全一致或多个一致的可能性微乎其微。】


如果真实数据会更加分散的话，我认为我的算法速度上会比你的更快。

我的明确思路如下：
1. 仅检查差异性最大的前n列。（n=19-15+1=5列）
2. 每列仅检查和本行数值相同的行。（不相同的行不用检查）
3. 全部5列中，只要任意一列的数值有相同的都要检查。
  因此检查完成后，剩余的其它各行，就一定是所有5列都没有一个数值和本行相同的了。
  那么，即使这以后余下的14列全部都和本行相同，也不会满足相同项目=15的要求了。


具体算法实现的要点，是用嵌套数组来储存、获取前n列中和本行具有相同的值的所有行位置。

所以本质上确实是很简单的思路。

陈国华

香川群子 发表于 2013-5-2 16:26
【对于水质监测的数据而言，真实的测量数据应该是十分分散的，也就是说除了同一水源水样外，水质指标数值 ...

我理解你的这个想法，我也是这样么想的，只是没有具体实现！

香川群子

具体代码的解释：

第1阶段，获取原始数据：
arr = Sheet1.[a1].CurrentRegion '原始数据读入数组arr
m = UBound(arr) '数据最大行数m  (第1行为标题行)
n = UBound(arr, 2) '数据最大列数n (第1列为序号列)
nn = n - nn + 1 '确定需要检查的列数 (即 nn=总列数-相同列数+1)
'由于数据的行、列都是从2开始，所以以后所有行列数值都比实际的要大1


第2阶段，用字典整理原始数据为长整形，以便快速计算：

   ReDim brr&(-1 To m, 2 To n) '定义数组brr用来存放整理后的长整型数据
   '行数扩展增加3行用来储存中间结果。所以从-1开始。（增加了 -1,0,1 共3行，以及实际数据行 2 to m）
   '列数和实际数据列保持一致（2 to n）
    Set d = CreateObject("Scripting.Dictionary") '设置一个字典d，循环使用2 to n次即可。
    For j = 2 To n '循环遍历各列
        ReDim crr(m) '定义临时数组crr，用来统计存放本列每个字典关键词的对应行的个数
     '我这样做，可以省去使用另一个字典，并提高速度（数组比字典更快！）
        For i = 2 To m '遍历检查本列中各行
            t = d(CStr(arr(i, j))) '检查对应行列交叉位置的数值是否已在字典内
            If t = "" Then k = k + 1: d(CStr(arr(i, j))) = k: t = k '如果不在字典内则字典新增k+1
            brr(i, j) = t '该行列交叉位置值根据字典转为长整型便于计算比对
            crr(t) = crr(t) + 1 '本字典值对应个数统计+1
        Next
        d.RemoveAll '本列全部遍历后，字典清空，以便下一列使用。
        brr(1, j) = k 'brr数组第1行存入该列字典关键字个数k
        For i = 1 To k '遍历k以便计算本列全部比对时需要的计算次数。
            brr(-1, j) = brr(-1, j) + crr(i) * (crr(i) + 1) / 2 '根据Σ=1 to 各字典项对应行总数来计算。
        ' brr(-1, j)相当于你代码中的.CmpCount
            ' crr(i)相当于你代码中的 Indexes(k).RowCount   
        Next
        k = 0 'k值初始化清零
    Next
    Set d = Nothing '全部整理完成后字典就不需要了。（这以后我都是通过数组完成计算，没有再用字典）
    ss = "Dic Process:   " & Format(Timer - tms, "0.000s"): tms = Timer
   
待续……

香川群子

第3阶段排序，确定需要检查的前nn列是哪几列。

    brr(0, 2) = 2 'brr数组中0行作为排列列序号位置 相当于你的arrPrmtIndSort()的作用
   '下面排序工作不解释了。我用的是比较落后的插值排序，没有用冒泡交换排序。
   '反正对整体速度影响不大。
    For i = 3 To n
        r = brr(-1, i)
        l = brr(1, i)
        For j = 2 To i - 1
            If r < brr(-1, j) Then
                For k = i To j + 1 Step -1
                    brr(-1, k) = brr(-1, k - 1)
                    brr(0, k) = brr(0, k - 1)
                    brr(1, k) = brr(1, k - 1)
                Next
                Exit For
            End If
        Next
        brr(-1, j) = r
        brr(0, j) = i
        brr(1, j) = l
    Next
    ss = ss & vbCr & "Sort:          " & Format(Timer - tms, "0.000s"): tms = Timer
   
'最后，
在brr数组的第-1行，是计算比对次数。
在brr数组的第 0行，是根据计算比对次数从小到大排序的列序号。（范围2 to n）
所以结果就是： 9,8,5,12,16,13,4,19,17,3,6,14,7,15,2,18,20,11,10
对应你的arrPrmtIndSort()的作用，但数值要大1 （你是1 to nItemNum）
在brr数组的第1行，是整个列的字典项关键词个数k

呵呵。
待续……

香川群子

接下来，才是我的算法的关键部分：

用嵌套数组来存放、获取每一行对应列中有相同值的所有行。

ReDim crr(2 To nn) '定义数组crr 用来存放前nn列对应的各种行信息（最后结果是一个嵌套数组）
    For l = 2 To nn '遍历前nn列
        j = brr(0, l) '根据排序结果转换为实际列位置j
        r = brr(1, l) '获取该列对应字典项目总数k
        ReDim x(1 To r) '每次重新定义数组x以便存放对应各个字典关键词的所有行位置信息
        For i = 2 To m '遍历该列所有行
            x(brr(i, j)) = x(brr(i, j)) & " " & i '对应数组x中汇总行位置信息
        Next
        '遍历各行整理完以后，在进行数组处理，存入crr嵌套数组
        For k = 1 To r '遍历各字典关键词
            y = Split(x(k)) '把汇总在x中的行信息字符串转换为一维数组y
            y(0) = UBound(y) '该一维数组y第一个0位置写入该x数组总个数（即具有相同值的行的总个数）
            x(k) = y '把这个整理好的一维数组y写回到x数组中形成嵌套数组x
        Next
        crr(l) = x '在crr中写入本列对应的嵌套数组x，使得crr成为一个二层嵌套数组
    Next
    ss = ss & vbCr & "Filter:        " & Format(Timer - tms, "0.000s"): tms = Timer
   

整理完成

待续。下面就是逐行检查比对了。