このコードで31〜50の値を見つけるための条件を追加するにはどうすればいいですか？私のコードは、1つの値に対して完全に機能します。
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
回答：
回答№1は2それを見る別の方法があります。ユニオンを使用すると効率的に貼り付けることができ、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
回答№2の場合は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
回答№3の場合は1
またはあなたが使うことができる 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