CODEWITHSUNDEEP
vbaexcel
Theadous Grubb
Theadous Grubb

Reputation: 21

move an entire row to another sheet if cell is less than a number

I have five columns: A through G.

1.I am trying to copy rows to "Sheet3" if column G > 0 but less than .03.

2.I want to copy rows to "Sheet4" if column 3 is > .03 but less than .04.

3.And copy rows to "Sheet5" if column G > .04.

Upvotes: 2

Views: 718

Answers (3)

user3598756
user3598756

Reputation: 29421

assuming your data have a header row:

Sub main()
    Dim iLimit As Long
    Dim sht As Worksheet
    Dim limits As Variant, targetSheets As Variant
    limits = Array("0", "0.03", "0.04") '<--| set array with your "limits"
    targetSheets = Array("Sheet3", "Sheet4", "Sheet5") '<--| set sheets names corresponding to 'limits' array items

    With Worksheets("MySheetName") '<--| change "MySheetName" to your actual worksheet name
        With Intersect(.UsedRange, .Columns("A:G")) '<--| consider its columns A to G cells
            For iLimit = LBound(limits) To UBound(limits) '<--| loop through limits array
                Set sht = Worksheets(targetSheets(iLimit)) '<--| set the target sheet corresponding to current "limit"
                If iLimit < UBound(limits) Then '<--| filter between an upper and a lower limit
                    .AutoFilter Field:=7, Criteria1:=">" & limits(iLimit), Operator:=xlAnd, Criteria2:="<" & limits(iLimit + 1)
                Else '<--| filter over a lower limit
                    .AutoFilter Field:=7, Criteria1:=">" & limits(iLimit)
                End If
                If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then .SpecialCells(xlCellTypeVisible).Copy Destination:=sht.Cells(Rows.Count, 1).End(xlUp).Offset(1) '<--| copy if any cells has been filtered other than header one
            Next iLimit
        End With
        .AutoFilterMode = False
    End With
End Sub

Upvotes: 0

Shai Rado
Shai Rado

Reputation: 33692

When looping through rows with data, and pasting to other sheets, it's better (and faster) to avoid using Activate all the time to Copy >> Paste. Also, it's recommended not to use ActiveCell and Select, instead use referenced Sheets, Cells and Range. For instance, using With Sheets("Sheet1").

The code below will loop through all rows of data, until LastRow with data in Column G, and check which of the criterias is met. Then it will paste it to the relevant sheet, to the first empty row in "Sheet3" / "Sheet4" / "Sheet5", in case these sheets already have existing data in them.

In my code I am using the PasteSpecial xlValues to paste only the values, but it can be modifed easily.

Note: in your post, you don't mention what do you do when Column G = .03 , or = .04.

Code

Option Explicit

Sub CopytoAnotherSheet()

Dim LastRow As Long, SrcRow   As Long

' mpdify "Sheet1" to your sheet's name where you hold your data
With Sheets("Sheet1")
    ' find last row with data in Column G
    LastRow = .Cells(.Rows.Count, "G").End(xlUp).Row

    ' loop through all rows, starting from 2nd rows (ususaly 1st row is the header row)
    For SrcRow = 2 To LastRow

        ' Cell in column G is > 0 and < 0.03
        If .Cells(SrcRow, 7).Value > 0 And .Cells(SrcRow, 7).Value < 0.03 Then
            .Cells(SrcRow, 7).EntireRow.Copy
            ' paste values to first empty row in Sheet3
            Sheets("Sheet3").Range("A" & Sheets("Sheet3").Cells(Sheets("Sheet3").Rows.Count, "G").End(xlUp).Row + 1).PasteSpecial xlValues
        Else
            ' Cell in column G is > 0.03 and < 0.04
            If .Cells(SrcRow, 7).Value > 0.03 And .Cells(SrcRow, 7).Value < 0.04 Then
                .Cells(SrcRow, 7).EntireRow.Copy
                ' paste values to first empty row in Sheet4
                Sheets("Sheet4").Range("A" & Sheets("Sheet4").Cells(Sheets("Sheet4").Rows.Count, "G").End(xlUp).Row + 1).PasteSpecial xlValues
            Else
                ' Cell in column G is > 0.04
                If .Cells(SrcRow, 7).Value > 0.04 Then
                    .Cells(SrcRow, 7).EntireRow.Copy
                    ' paste values to first empty row in Sheet5
                    Sheets("Sheet5").Range("A" & Sheets("Sheet5").Cells(Sheets("Sheet5").Rows.Count, "G").End(xlUp).Row + 1).PasteSpecial xlValues
                End If
            End If
        End If

    Next SrcRow
End With

End Sub

Upvotes: 0

Collier
Collier

Reputation: 56

Your code might look something like this.

Sub ConditionalCopy()

'set cells in position on target sheets
Sheets("Sheet3").Activate
Range("A2").Select
Sheets("Sheet4").Activate
Range("A2").Select
Sheets("SHeet5").Activate
Range("A2").Select

'go to sheet with data
Sheets("Sheet1").Activate
'Assuming headers in Row 1 and data starts in row 2
Range("A2").Select

'Loop through rows until empty cell ( end of data )
Do While ActiveCell.Value <> ""

If Range("G" & ActiveCell.Row).Value > 0 And Range("G" & ActiveCell.Row).Value < 0.3 Then
    ActiveCell.EntireRow.Copy
    Sheets("Sheet3").Activate
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
        ActiveCell.Offset(1, 0).Select
    Sheets("Sheet1").Activate
End If

If Range("C" & ActiveCell.Row).Value > 0.03 And Range("C" & ActiveCell.Row).Value < 0.04 Then
    ActiveCell.EntireRow.Copy
    Sheets("Sheet4").Activate
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
        ActiveCell.Offset(1, 0).Select
    Sheets("Sheet1").Activate
End If

If Range("G" & ActiveCell.Row).Value > 0.04 Then
    ActiveCell.EntireRow.Copy
    Sheets("Sheet5").Activate
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
        ActiveCell.Offset(1, 0).Select
    Sheets("Sheet1").Activate
End If

 ActiveCell.Offset(1, 0).Select

 Loop

 End Sub

Upvotes: 1

Related Questions