Question

如何在此代码中添加条件以查找31到50之间的值。我的代码只适用于一个值。

Private Sub CommandButton1_Click()

a = Worksheets("Test").Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To a
    If Worksheets("Test").Cells(i, 10).Value = "30.00" Then
        Worksheets("Test").Rows(i).Copy
        Worksheets("Above").Activate
        b = Worksheets("Above").Cells(Rows.Count, 1).End(xlUp).Row
        Worksheets("Above").Cells(b + 1, 1).Select
        ActiveSheet.Paste
        Worksheets("Test").Activate
    End If
Next

Application.CutCopyMode = False

ThisWorkbook.Worksheets("Test").Cells(1, 1).Select

End Sub

Answer 1

请尝试以下代码查找31到50之间的值。

注意：不需要Activate和Select，只需使用完全限定的对象，如下面的代码所示。

代码

Option Explicit

Private Sub CommandButton1_Click()

Dim a As Long, b As Long, i As Long

With Worksheets("Test")
    a = .Cells(.Rows.Count, 1).End(xlUp).Row

    For i = 2 To a
        If .Cells(i, 10).Value >= 31 And .Cells(i, 10).Value <= 50 Then
            b = Worksheets("Above").Cells(Worksheets("Above").Rows.Count, 1).End(xlUp).Row ' get last row in "Above" sheet

            ' copy >> paste in 1-line withou using Select
            .Rows(i).Copy Destination:=Worksheets("Above").Cells(b + 1, 1)
        End If
    Next
End With

Application.CutCopyMode = False

End Sub

Answer 2

这是另一种看待它的方式。使用Union是一种有效的粘贴方式，而且b的计算量较少。

Option Explicit

Private Sub CommandButton1_Click()

    Dim a As Long
    Dim b As Long
    Dim i As Long
    Dim unionRng As Range

    With Worksheets("Test")

        a = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        i = 2

        If i > a Then Exit Sub

        Dim currValue As Long 'change if required

        Do Until i = a

             currValue =  .Cells(i, 10)

            If currValue >= 31 And currValue <= 50 Then

                If Not unionRng Is Nothing Then
                    Set unionRng = Union(unionRng, .Rows(i))
                Else
                    Set unionRng = .Rows(i)
                End If
            End If
            i = i + 1

        Loop

    End With

    b = Worksheets("Above").Cells(Worksheets("Above").Rows.Count, 1).End(xlUp).Row

    b = IIf(b = 1, 1, b + 1)

    If Not unionRng Is Nothing Then

        unionRng.Copy Worksheets("Above").Cells(b, 1)

    End If

End Sub

Answer 3

或者您可以使用AutoFilter()

Private Sub CommandButton1_Click()
    With Worksheets("Test")
        With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
            .AutoFilter Field:=1, Criteria1:=">=31", Operator:=xlAnd, Criteria2:="<=50"
            If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Intersect(.parent.UsedRange, .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow).copy Destination:=Worksheets("Above").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        End With
        .AutoFilterMode = False
    End With
End Sub

在IF THEN语句中添加多个值

3 个答案: