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]

Do you mean...?

Sub 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 Range("C" & Rows.Count).End(xlUp)(2)
                .ClearContents
            
            
                On Error Resume Next
                ActiveSheet.AutoFilterMode = False
                .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

 

[Alrock]

Wow! very close. I need to keep all rejected values so It's possible to write the next rejected value below the previous and not overwrite?

 

[MARK858]

What overwrites in that code???

 

[Alrock]

What overwrites in that code???

The non desired value goes to C column and the next non desired value overwrite the previous one.

 

[MARK858]

Where? This line

.Copy Range("C" & Rows.Count).End(xlUp)(2)

"Pastes" the data in the next cell after the last cell with data in Column C and it sends the data in one go, it doesn't loop.

 

[Alrock]

Yes, that line copy the value out of the range to column C but the next value out of range overwrite the previous one, I need to keep them all.

 

[MARK858]

Try..

Sub 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
          
            With .Offset(1)
                .AutoFilter 1, "<193", xlOr, ">196"
                .ClearContents
          
                On Error Resume Next
                .SpecialCells(4).Delete xlUp
                On Error GoTo 0
            End With
        End With
      
        ActiveSheet.AutoFilterMode = False
        Application.Goto .Range("B" & Rows.Count).End(xlUp)(2)
    End With

   
    Application.ScreenUpdating = True
End Sub

 

[Alrock]

Now it's cutting and copying number out of range to column C very well but it's deleting first cell in column B and moving the others cells one up.

 

[MARK858]

Try changing

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

to

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