Re: [ExcelVBA] Code that needs help

 

There are several issues with your code but the  the error message about multiple selections is correctly telling you that VBA is trying to do a cut with non-contiguous cells. The problem arises because the line that sets the cell to cut, in addition to getting the right cell, is also getting a cell one row beyond the rectangle you are filtering.  Debug.Print rRowsWithCellToCut.Address in the right place will demonstrate this.

I am not sure if this is a bug in Excel itself but it is certainly a confusion issue. The workaround is to select the first cell in the filtered range.

The code below does what you want as far as I understand what you are trying to do. Notice that if two or more rows meet your criteria then only the first cell is moved.

Sub Bob()

Dim rFilteredRectangle As Range, rRowsWithCellToCut As Range, rCellToCut As Range

Dim nLastrow As Long

    nLastrow = Cells(Rows.Count, "C").End(xlUp).Row

    Set rFilteredRectangle = Range("C1").Resize(nLastrow)

    rFilteredRectangle.AutoFilter Field:=1, Criteria1:="=20", Operator:=xlOr, Criteria2:="=33"

    Set rRowsWithCellToCut = rFilteredRectangle.offset(1).SpecialCells(xlCellTypeVisible)

     With rRowsWithCellToCut

        Set rCellToCut = .Range(Cells(1, 1), Cells(1, 1))

        If Not IsEmpty(rCellToCut) Then rCellToCut.CUT Range("A1")       ' or wherever ?

    End With

    Range("C1").AutoFilter

 End Sub 

Regards

Derek Turner

England +++

---

From: "mgarza@fellowes.com [ExcelVBA]" <ExcelVBA@yahoogroups.com>
To: ExcelVBA@yahoogroups.com
Sent: Friday, 8 April 2016, 18:46
Subject: RE: [ExcelVBA] Code that needs help

 

Bob,

Thanks for your help previously. I've been trying to tweak this code in a way so that a cell that fits a specific criteria will be cut and pasted into a new location. I tried several different commands and combination of commands but I get an error saying the command I chose cannot be performed with multiple selections. I am obviously not an experienced coder. I tried the changes highlighted in yellow below. Do you have any feedback that might help?

 

Dim rng As Range
Dim lastrow As Long

Application.ScreenUpdating = False

With ActiveSheet

 

lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row

Set rng = .Range("C1").Resize(lastrow)

rng.AutoFilter Field:=1, Criteria1:="=20", Operator:=xlOr, Criteria2:="=33"

On Error Resume Next

Set rng = rng.Offset(1).SpecialCells(xlCellTypeVisible)

On Error GoTo 0

If Not rng Is Nothing Then rng.cells.cut

rng.Offset(, 1).Paste

.Range("C1").AutoFilter

   

End With

Application.ScreenUpdating = True

End Sub

 

__._,_.___

---

Posted by: Derek Turner <g4swy@yahoo.com>

---

Reply via web post

•

Reply to sender

•

Reply to group

•

Start a New Topic

•

Messages in this topic (6)

----------------------------------
Be sure to check out TechTrax Ezine for many, free Excel VBA articles! Go here: http://www.mousetrax.com/techtrax to enter the ezine, then search the ARCHIVES for EXCEL VBA.

----------------------------------
Visit our ExcelVBA group home page for more info and support files:
http://groups.yahoo.com/group/ExcelVBA

----------------------------------
More free tutorials and resources available at:
http://www.mousetrax.com

----------------------------------

Visit Your Group

• Privacy • Unsubscribe • Terms of Use

.

__,_._,___