/ / Pridajte viac hodnôt v príkaze IF THEN - excel, vba, excel-vba

Pridajte viacero hodnôt v prípade IF THEN - excel, vba, excel-vba

Ako pridám podmienku na nájdenie hodnôt od 31 do 50 v tomto kóde. Môj kód funguje perfektne iba s jednou hodnotou.

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

odpovede:

2 pre odpoveď č. 1

Tu je ďalší spôsob, ako sa na to pozrieť. Použitie Union je efektívny spôsob, ako prilepiť jediným krokom a urobíte menej výpočtov pre 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

1 pre odpoveď č. 2

Vyskúšajte nižšie uvedený kód, aby ste našli hodnoty od 31 do 50.

Poznámka: nie je potrebné Activate a Select, stačí použiť plne kvalifikované objekty ako v nižšie uvedenom kóde.

kód

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

1 pre odpoveď č. 3

alebo môžete použiť 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