[已解决]请问如何设置条件筛选删除不需要的数对

mushroom97

各位高手，有问题请教：
如图1所示，A列和B列是原始数据列，从第二行开始，不固定结束行数，但是二者结束会保持一致；
现在需要针对B列中差值小于0.01的两个数（如B1和B3）所对应的A列数字（对应A1和A3）再进行比较，如果对应A列数字差值小于0.05，则认为两组数据重复，可删除任意一组（A1，B1）或（A3，B3），同时下方单元格上移。
依次类推。

这样的工作表有数十个，且每列数据有几千个，请问如何使用VBA实现自动比较和删除？
非常感谢！

图1

最佳答案

月排行榜 / 总排行榜

我行我速2008

2022-9-7 10:47

111111111111111

跳转到最佳答案楼层

mushroom97

各位大神，求求了

我行我速2008

没附件，未经测试，试试吧！以后求助贴一定要上传附件！！
Sub tt()
    Dim Ar, Br(), R&, X&, K&
    Dim Sh As Worksheet
    For Each Sh In Worksheets
        With Sh
            .Columns("D:E").ClearContents
            Ar = .[a1].CurrentRegion
            For R = 1 To UBound(Ar) - 1
                For X = R + 1 To UBound(Ar)
                   If Abs(Ar(R, 2) - Ar(X, 2)) < 0.01 Then
                        If Abs(Ar(R, 1) - Ar(X, 1)) < 0.05 Then
                            Ar(X, 1) = 0: Ar(X, 2) = 0
                        End If
                   End If
                Next X
            Next R
            For R = 1 To UBound(Ar)
                If Ar(R, 1) <> 0 Then
                    K = K + 1
                    ReDim Preserve Br(1 To 2, 1 To K)
                    Br(1, K) = Ar(R, 1)
                    Br(2, K) = Ar(R, 2)
                End If
            Next R
            .[d1].Resize(K, 2) = Application.Transpose(Br)
            Erase Br
            K = 0
        End With
    Next Sh
End Sub

mushroom97

我行我速2008 发表于 2022-8-23 09:48
没附件，未经测试，试试吧！以后求助贴一定要上传附件！！
Sub tt()
    Dim Ar, Br(), R&, X&, K&

感谢大佬回复！我运行后显示调试错误，


这要怎么debug啊

我行我速2008

附件！！！！没附件，可能写出来的东西和你的表格有冲突！！！

mushroom97

附件来啦QAQ

我行我速2008

111111111111111

mushroom97

我行我速2008 发表于 2022-9-7 10:47
111111111111111

十分感谢大佬，尝试运行了一些数据是没有问题的！再次跪谢！！！

我行我速2008

认这行就选为最佳答案。