Cut a cell from one column and paste to another.

[Alrock]

Hello everybody. I hop someone can help me with this. I work with a scale that continuously write the weights values to an excel sheet in one column, I need to cut the values that are out of the range of weight that I need from column B and paste them to column C, one after another and also I need after cut and paste each non desired value that the selected cell return to the next empty cell in column B to the scale continue writing . The range of weight is (>=193 and <=196) or (>192 and <197)

I was working whit this code because I was deleting the entire row with non desired values but now I need to keep them separated.

Sub test()
With ActiveSheet
.AutoFilterMode = False
With Range("B1", Range("B" & Rows.Count).End(xlUp))
.AutoFilter 1, ">196"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete Shift:=x1Up
End With
.AutoFilterMode = False
ActiveCell.Offset(rowOffset:=-1, columnOffset:=0).Activate
End With
End Sub


Thank you.

 

[MARK858]

If you still have your range set as B2 and not B1 then you will get an incorrect result if you only have an entry in B2.

 

[MARK858]

See what you get with the code below (do not change the B1 to B2)

Sub test()

    'RunTimer = Now + TimeValue("00:00:01")
    'Application.OnTime RunTimer, "test"

    With ActiveSheet
        Application.ScreenUpdating = False
        .AutoFilterMode = False

        With .Range("B1", .Range("B" & Rows.Count).End(xlUp))
            .AutoFilter 1, "<193", xlOr, ">196"

            With .Offset(1)
                .Copy
                ActiveSheet.AutoFilterMode = False
                Range("C" & Rows.Count).End(xlUp)(2).PasteSpecial
            End With

            Application.CutCopyMode = False

            .AutoFilter 1, "<193", xlOr, ">196"
            With .Offset(1)
                .ClearContents
              ActiveSheet.AutoFilterMode = False
                On Error Resume Next
                .SpecialCells(4).Delete xlUp
                On Error GoTo 0
            End With
        End With

        
       Application.Goto .Range("B" & Rows.Count).End(xlUp)(2)
    End With


    Application.ScreenUpdating = True

End Sub

'Sub Stopweight()
'
'Application.OnTime RunTimer, "test", , False
'End Sub

 

[Alrock]

When I ran it when timer on the second time it ran it cut and paste all values from column B to C