组数据筛选的问题

杨小妹

附件 组数据筛选附件.rar (406 KB, 下载次数: 8)

2024-8-21 14:12 上传

点击文件名下载附件

谢谢老师！

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

今铭昔

杨小妹

ykcbf1100 发表于 2024-8-21 14:26
附件供参考。。。

老师你好，谢谢帮助。试了一下，效果很好。只是数据太多了，结果有点意想不到的多。麻烦看看能否增加一个条件。即每一组的  C 列上下两个数，要求相同。这样，出来的结果就会减少很多。

ykcbf1100

杨小妹 发表于 2024-8-21 15:25
老师你好，谢谢帮助。试了一下，效果很好。只是数据太多了，结果有点意想不到的多。麻烦看看能否增加一个 ...

改好了。。。

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, r&, k&, iPosRow&
   
    Application.ScreenUpdating = False
   
    r = Cells(Rows.Count, "A").End(xlUp).Row
    ar = Range("A1:G1" & r).Value
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
   
    r = 0
    For i = 1 To UBound(ar) Step 3
        If ar(i, 3) = ar(i + 1, 3) Then
            If (ar(i, 6) = ar(i + 1, 6)) And ar(i, 7) = "A" And ar(i + 1, 7) = "B" Then
                r = r + 1
                iPosRow = (r - 1) * 3 + 1
                For k = 0 To 1
                    For j = 1 To UBound(ar, 2)
                        br(iPosRow + k, j) = ar(i + k, j)
                    Next j
                Next k
            End If
        End If
    Next i
        
    [Q1].Resize(iPosRow + 1, UBound(br, 2)) = br
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

..................