[已解决]查询组数据相同的问题

晓敏

附件 查询相同附件.rar (21.9 KB, 下载次数: 10)

2016-4-3 19:25 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

高

2016-4-4 06:57

真行了，原来没注意到“三”组相同。

跳转到最佳答案楼层

高

可以实现

晓敏

高 发表于 2016-4-3 21:36
可以实现

老师你好，附件中的Ａ列数据中，三组完全相同的，只有一个．如下图




你的附件中，查出来的，有三个，都不符合条件．麻烦看看．谢谢．

高

晓敏 发表于 2016-4-3 22:17
老师你好，附件中的Ａ列数据中，三组完全相同的，只有一个．如下图

我看看啊

爱疯

查询相同附件2.rar (40.63 KB, 下载次数: 5)

2016-4-3 22:33 上传

点击文件名下载附件





Option Explicit

Dim group As Integer    '多少个一组
Dim sp As Integer       '每组间隔多少行
Dim A                   '数据源
Sub test()
    Dim groups, i, j, s, B(), C()

    '1）初值
    group = 10
    sp = 3
    A = Range("a1:a" & Range("a65536").End(xlUp).Row)
    groups = UBound(A) \ (group + sp)
    If UBound(A) Mod (group + sp) Then groups = groups + 1

    '2）找出重复的组号
    For i = 1 To groups
        For j = i + 1 To groups
            '如果为true，表示存在重复。记录i或j即可
            If compare(i, j) Then s = s + 1: ReDim Preserve B(1 To s): B(s) = j
        Next j
    Next i

    '3）根据组号，提取数据到C
    ReDim C(1 To UBound(A), 1 To 1)
    For i = 1 To UBound(B)
        For j = 1 To group
            '(i - 1) * (group + sp)表示 （组号-1）*每组的成员数
            C((i - 1) * (group + sp) + j, 1) = A((i - 1) * (group + sp) + j, 1)
        Next j
    Next i

    '4）输出
    Range("L:L").ClearContents
    [L1].Resize((i - 1) * (group + sp)) = C
End Sub

Function compare(i, j) As Boolean
    Dim k
    compare = True
    For k = 1 To group
        If A((i - 1) * (group + sp) + k, 1) <> A((j - 1) * (group + sp) + k, 1) Then compare = False: Exit For
    Next k
End Function




是这样吗？
因为实际数据，不便直接查看结果对不对。
所以，我单独做了一个简单的附件，以便查看。
这两个工作簿，所用代码是一样的。

高

刚才把区域选小了。

晓敏

爱疯 发表于 2016-4-3 22:37
Option Explicit

Dim group As Integer    '多少个一组

老师你好，谢谢了。你可能理解错了题意。所谓十行为一组，如下图所示：



这样就是一组。



这样又是一组


。
这是A列中的第三组。

很显然，这三组数据，并不是完全相同的。

题意是：在A列中，如果有 三组完全相同的，就返回结果。

如三楼所示，那三组数据，就是完全相同的。

爱疯

简单示例2.rar (10.65 KB, 下载次数: 4)

2016-4-3 23:39 上传

点击文件名下载附件



Sub test()
    Dim members As Integer  '每组有几个
    Dim groups As Integer   '一共有几组
    Dim A, B, C(), k, t, d
    Dim i, j, str

    '1）初值
    members = 13
    i = Range("a65536").End(xlUp).Row
    groups = i \ members
    If groups Then groups = groups + 1
    A = Range("a1:a" & members * groups)
    Set d = CreateObject("scripting.dictionary")

    '2）录入字典
    For i = 1 To UBound(A) Step members
        str = ""
        For j = 1 To members
            str = str & "," & A(i + j - 1, 1)
        Next j
        d(str) = d(str) + 1
    Next i

    '3）提取满足条件（>2）
    k = d.keys: t = d.items
    ReDim C(1 To UBound(A), 1 To 1)
    For i = 0 To UBound(k)
        If t(i) > 2 Then
            B = VBA.Split(k(i), ",")
            For j = 1 To UBound(B)
                C((i - 1) * members + j, 1) = B(j)
            Next j
        End If
    Next i

    '4）输出
    Range("L:L").ClearContents
    [L1].Resize(UBound(C)) = C
End Sub




没看懂你的说明，我改了下：
如图，绿色的有3组，即只有绿色满足条件，所以结果只有绿色这一组。是这样吗？

晓敏

爱疯 发表于 2016-4-3 23:39
Sub test()
    Dim members As Integer  '每组有几个
    Dim groups As Integer   '一共有 ...

老师你好，我把你的代码复进去，试了一下，没有反应。
如下附件：

A列数据中，就只有一个（三组完全相同）符合条件。已标在L列中。

爱疯

现在下线了，假如你把数据改下：

a1:a13是1到13
a14:a26也是1到13
a27:a39也是1到13

再运行，L列有没有1到13呢？