Senin, 11 April 2016

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

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

.

__,_._,___

Tidak ada komentar:

Poskan Komentar