历遍工作表筛选的问题

谢玉红

附件 历遍工作表筛选.rar (1006.95 KB, 下载次数: 7)

2023-3-3 09:24 上传

点击文件名下载附件

谢谢老师！

无敌小猪猪

仅供参考！

ykcbf1100

附件请参考。。。

无敌小猪猪

ykcbf1100 发表于 2023-3-3 09:50
附件请参考。。。

还是你这个快一点，我不应该分批读入的

谢玉红

ykcbf1100 发表于 2023-3-3 09:50
附件请参考。。。

老师你好，非常感谢。试了一下，很快。但返回的结果不能放在Sheet0里。各工作表中，返回的结果，就保存在各工作表原来的位置。换句话说：把各工作表中，不符合条件的行，全部删除。符合条件的，依次上移。不知能否麻烦老师改一下。再谢了。

谢玉红

无敌小猪猪 发表于 2023-3-3 09:45
仅供参考！

谢谢老师帮助。。。。。。。。。。。。。。。。。。。

谢玉红

无敌小猪猪 发表于 2023-3-3 09:45
仅供参考！

老师你好，返回结果应该保存在各工作表的原位置。

liulang0808

Sub test()
    Set d = CreateObject("scripting.dictionary")
    Sheets(1).Select
    Application.ScreenUpdating = False
    For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
       If Len(Cells(1, j)) > 0 Then d(j) = Cells(1, j)
    Next j
    For j = 2 To Sheets.Count
        arr = Sheets(j).UsedRange
        r = 0
        For i = 1 To UBound(arr)
            For k = 1 To UBound(arr, 2)
                If d.exists(k) Then
                    If arr(i, k) <> d(k) Then
                        GoTo l1
                    End If
                End If
            Next k
            r = r + 1
            For k = 1 To UBound(arr, 2)
                arr(r, k) = arr(i, k)
            Next k
l1:
        Next i
        If r > 0 Then
            Sheets(j).UsedRange.Offset(1).ClearContents
            Sheets(j).[a1].Resize(r, UBound(arr, 2)) = arr
        End If
    Next
    Application.ScreenUpdating = True
End Sub

liulang0808

第一行可以根据需求保留多个比对值

ykcbf1100

谢玉红 发表于 2023-3-3 10:05
老师你好，非常感谢。试了一下，很快。但返回的结果不能放在Sheet0里。各工作表中，返回的结果，就保存在 ...

可以改的，稍等。