在IF THEN語句中添加多個值

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