我相信以下几点可以帮助你达到预期的效果：

Sub deviation()
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim wsCopyFrom As Worksheet: Set wsCopyFrom = wb.Sheets("Sheet1")
    Dim wsPasteTo As Worksheet: Set wsPasteTo = wb.Sheets("Sheet2")
    'above declare and set the relevant worksheets
    Dim LastRowSheet1 As Long, LastRowSheet2 As Long, counter As Long
    'declare variables to verify last rows in both worksheets

    LastRowSheet1 = wsCopyFrom.Cells(Rows.Count, 1).End(xlUp).Row
    'get the last row with some data on Column A Sheet1
    NextRowSheet2 = wsPasteTo.Cells(Rows.Count, 1).End(xlUp).Row + 1
    'get the last row with some data on Column A Sheet2 and add 1
    
    For counter = 1 To LastRowSheet1
    'loop throught Rows 1 to Last on Sheet1
        If wsCopyFrom.Cells(counter, 2).Value >= "3000" Or wsCopyFrom.Cells(counter, 3).Value >= "3000" Or wsCopyFrom.Cells(counter, 4).Value >= "3000" Then
        'Check if any value in Column B, C or D have a value greater or equal to 3000
            wsCopyFrom.Rows(counter).EntireRow.Copy wsPasteTo.Range("A" & NextRowSheet2)
            NextRowSheet2 = NextRowSheet2 + 1
        End If
    Next counter
End Sub

字符串

首先，这里是你的代码和注解：

Sub deviation()

    Dim DataRg As Range
    Dim blankrng As Range
    Dim cell As Range
    Dim I As Long

'You have not Declared Q
    Q = Worksheets("Sheet2").UsedRange.Rows.Count 
'You have not Declared P
    P = Worksheets("Sheet1").UsedRange.Rows.Count

'You never set the value of I, so it is ALWAYS 0...
    If I = 1 Then
'... meaning that this bit will NEVER run
        If Application.WorksheetFunction.CountA(Worksheets("Sheet1").UsedRange) = 0 Then Q = 0
    End If

'Your sample data makes P = 3.  This means you are looking at Range B2:W1853
'Did you mean Worksheets("Sheet1").Range("b2:w" & P) instead?
    Set DataRg = Worksheets("Sheet1").Range("b2:w185" & P)
'You never set this back to True
    Application.ScreenUpdating = False

'I is always 0, so this will throw an error
    If CStr(DataRg(I).Value) >= "3000" Then
'This is an Object.  You Excel/VBA wants to know what you want to DO with the object!
        EntireRow.EntireRow
    End If
    
End Sub

字符串
那么，让我们看看什么可能会起作用：

Option Explicit 'Throw an Error if you forgot to Declare any Variables
Sub deviation()
    Dim wsSrc AS Worksheet, wsDest AS Worksheet
    Set wsSrc = Worksheets("Sheet1") 'Possibly ThisWorkbook.Worksheets(..)
    Set wsDest = Worksheets("Sheet2") 'Or maybe ActiveWorkbook.Worksheets(..)
    
    If Application.CountA(wsSrc .Cells(1,1).CurrentRegion) < 1 Then Exit Sub 'If there is no data in the Source Sheet
    
    Dim SourceRow As Range, lOutputRow AS Long
    
    'Find an Empty row in the Destination sheet
    If Application.CountA(wsDest.Cells(1,1).CurrentRegion) > 0 Then
        lOutputRow = 1 + wsDest.Cells(1,1).CurrentRegion.Rows.Count 'UsedRange can be buggy if you delete rows
        'Using Range.End(..) or Range.CurrentRegion are more reliable
    Else
        lOutputRow = 1 'If there is no data already in the Destination Sheet
    End IF
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    For Each SourceRow In wsSrc.Cells(1,1).CurrentRegion.Rows 'Step through each row, one at a Time
        If Application.CountIf(SourceRow, ">=3000") > 0 Then 'At least 1 cell in the row has a value >= 3000
            SourceRow.Copy Destination:=wsDest.Rows(lOutputRow) 'Copy to Destination Sheet
            lOutputRow = lOutputRow + 1 'Move Output to the next row down
        End If
    Next SourceRow
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

型

复制匹配项

的数据

Sub CopyMatchingRows()
    
    ' Constants
    Const SRC_SHEET_NAME As String = "Sheet1"
    Const SRC_CRITERIA_COLUMNS As String = "B:W"
    Const DST_SHEET_NAME As String = "Sheet2"
    Const GREATER_THAN_VALUE As Double = 3000
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET_NAME)
    
    Dim srg As Range, srCount As Long, scCount As Long

    With sws.UsedRange
        srCount = .Rows.Count - 1 ' exclude headers
        Set srg = .EntireRow.Columns(SRC_CRITERIA_COLUMNS) _
            .Resize(srCount).Offset(1)
        scCount = srg.Columns.Count
    End With
       
    Dim sData() As Variant: sData = srg.Value
       
    Dim surg As Range, sValue As Variant, sr As Long, sc As Long
    
    For sr = 1 To srCount
        For sc = 1 To scCount
            sValue = sData(sr, sc)
            If VarType(sValue) = vbDouble Then ' is a number
                If sValue > GREATER_THAN_VALUE Then
                    If surg Is Nothing Then
                        Set surg = srg.Cells(sr, 1)
                    Else
                        Set surg = Union(surg, srg.Cells(sr, 1))
                    End If
                    Exit For
                End If
            End If
        Next sc
    Next sr
            
    If surg Is Nothing Then
        MsgBox "No matching rows found.", vbExclamation
        Exit Sub
    End If
    
    ' Destination
    
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET_NAME)
    
    Dim dcell As Range:
    With dws.UsedRange
        Set dcell = .Cells(1).EntireRow.Columns("A").Offset(.Rows.Count)
    End With
    
    ' Copy.
    surg.EntireRow.Copy dcell
    
    ' Inform.
    MsgBox "Matching rows copied.", vbInformation
     
End Sub

字符串