Sub gj23w98()
 Dim brr(1 To 5000, 1 To 28)
    For Each sht In Sheets
        If sht.Name <> ActiveSheet.Name Then
            With sht
                 r = .Cells(.Rows.Count, 1).End(3).Row
                 arr = .Range("a3:i" & r)
            End With
            For i = 1 To UBound(arr)
                If InStr(arr(i, 3), [c1]) > 0 Or InStr(arr(i, 20), [f1]) > 0 Then
                    m = m + 1
                    For j = 1 To UBound(arr, 2)
                       brr(m, j) = arr(i, j)
                    Next
                End If
            Next
        End If
    Next
    If m > 0 Then
        Range("a3:i" & Rows.Count).ClearContents
        [a3].Resize(m, 28) = brr
    Else
        MsgBox "没有找到相关数据，请查证！"
    End If
End Sub

太感谢您了我再试试，之前一直没找到问题出在哪里了，谢谢您

谢谢您看了您的代码，恍然大悟，知道我的问题出在哪里了，又学习了

代码试了，很好用，正是我想实现的效果，太感谢了，解决了我的难题