Seleccionar por grupos y Sortear Individualmente.

[chomsky]

Este codigo Sombrea ó Selecciona todos los rows que dicen cortar en un sheet, pero no puedo sortearlos de esa manera. Creo.

Quiero escogerlos por grupos para poder sortearlos por Columns E,F,G cada uno de los grupos de rows que digan cortar en la columna I.

Option Explicit
Sub RowsSELECT()
Dim k As Long
Dim myWord As String
Dim myRng As Range
Dim wks As Worksheet
Set wks = ActiveSheet
myWord = "CORTAR"
If myWord <> "" Then
With wks
For k = .Cells(.Rows.Count, "I").End(xlUp).row To 1 Step -1
If InStr(1, CStr(.Cells(k, "I")), myWord, vbTextCompare) Then
If myRng Is Nothing Then
Set myRng = .Cells(k, "A")
Else
Set myRng = Union(myRng, .Cells(k, "A"))
End If
End If
Next k
End With
End If
If myRng Is Nothing Then
MsgBox "Not found"
Else
'wks.Select 'not needed if you are processing the activesheet
myRng.EntireRow.Select
End If
End Sub

 

[chomsky]

Ninguna Idea ?

 

[Greg Truby]

No entiendo claramente qué es lo que usted desea hacer. El código que usted puso debe de seleccionar todas las fila donde la palabra "CORTAR" aparece en la columna "I". Aunque no es muy bonito, el código que usted puso sí funciona. Pero aquí le doy una revisión empleando varias tecnicas consideradas como "best practices".

Sub SelectRows2()
    Const c_strPalabra As String = "Cortar"
 
    Dim rngToSearch As Excel.Range, rngCell As Excel.Range, rngFinds As Excel.Range, _
        lngLastRow As Long, strFirstAddr As String, lngCounter As Long
 
 
    Let lngLastRow = Range("I" & Rows.Count).End(xlUp).Row
 
    Set rngToSearch = Range("I1:I" & lngLastRow)
 
    Set rngCell = rngToSearch.Find(What:=c_strPalabra, _
                                   LookAt:=XlLookAt.xlPart, _
                                   MatchCase:=False)
    If rngCell Is Nothing Then
 
        MsgBox "No se encontró " & c_strPalabra & " en rango " _
             & rngToSearch.Address(False, False, xlA1), _
             vbInformation, "Falla"
        Exit Sub
 
    Else
 
        Let strFirstAddr = rngCell.Address
        Do
            Set rngFinds = fnUnion(rngFinds, rngCell)
            Set rngCell = rngToSearch.FindNext(After:=rngCell)
 
            '// cuando un está haciendo un do/loop o
            '// while/wend siempre es buena idea
            '// proteger contra bucle sin fin
            lngCounter = lngCounter + 1
            If lngCounter > lngLastRow Then Exit Do
 
        Loop Until rngCell.Address = strFirstAddr
 
    End If
 
    rngFinds.EntireRow.Select
 
End Sub
 
' _____________________________________________________________________________
' fn Union
' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
' Descrip:  If you attempt to build a range that is the union of ranges and any
'           of the input range objects is nothing, Union() will fail.  This routine
'           checks first and then adds the range if it's not nothing.
'
' Args:     Rngs()· · · · · a list of ranges to join using the UNION function
'
' Returns:  Range · · · · · the Union of all range objects passed in excluding
'                           any range objects that were nothing (or anything
'                           passed in that was not a range object).
'
' Date          Developer   Comments
' ¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨
' 17 Aug 2007   T. Mehta    • initial version
'             & A. Pope     • taken from here:
'                             http://www.dailydoseofexcel.com/archives/2007/08/17/ _
                              two-new-range-functions-union-and-subtract/
' _____________________________________________________________________________
' ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Function fnUnion(ParamArray Rngs()) As Excel.Range
' _____________________________________________________________________________
    Dim rngUnion As Excel.Range
    Dim vntX As Variant
 
    For Each vntX In Rngs
        If Not vntX Is Nothing Then
            If TypeName(vntX) = "Range" Then
                If rngUnion Is Nothing Then
                    Set rngUnion = vntX
                Else
                    Set rngUnion = Union(rngUnion, vntX)
                End If
            End If
        End If
    Next
 
    If Not rngUnion Is Nothing Then Set fnUnion = rngUnion
End Function '// fnUnion

 

[chomsky]

Muchas Gracias Greg, Si funciona , pero yo quiero sortear esos grupos que quedan juntos por la columnas E F G.

Tengo este codigo con una parte para sortear pero me da error 91
Run-Time Error 91
Object Variable or With block variable not set


Sub RowsSELECT()

Dim Group As Range
Dim LastCell As Range
Dim k As Long
Dim myWord As String
Dim myRng As Range
Dim wks As Worksheet

Set wks = ActiveSheet
myWord = "CORTAR"

'Find the last cell with data in the last Column used
LastCell = wks.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False)
If LastCell Is Nothing Then Exit Sub
If myWord <> "" Then
With wks
For k = .Cells(.Rows.Count, "I").End(xlUp).row To 1 Step -1
If InStr(1, CStr(.Cells(k, "I")), myWord, vbTextCompare) Then
If myRng Is Nothing Then Set myRng = .Cells(k, "A")
Set myRng = Union(myRng, .Cells(k, "A"))
End If
Next k
End With
End If

If myRng Is Nothing Then
MsgBox "LA PALABRA '" & myWord & "' NO SE ENCUENTRA."
Exit Sub
End If

For Each Group In myRng.Areas
Set Group = Group.Resize(ColumnSize:=LastCell.Column)
Group.Sort Key1:=Group.Cells(1, "E"), Order1:=xlAscending, _
Key2:=Group.Cells(1, "F"), Order2:=xlAscending, _
Key3:=Group.Cells(1, "G"), Order3:=xlAscending, _
Header:=xlNo, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal, _
DataOption3:=xlSortNormal
Next Group

'wks.Select 'not needed if you are processing the activesheet
'myRng.EntireRow.Select


End Sub
</PRE>

 

[galileogali]

No será[
LastCell = wks.Cells.Find("*",Range("A1"), xlValues, xlWhole, xlByRows, xlPrevious, False)

 

[Greg Truby]

También puede ser la falta de Range("A1"). Pero sin duda un problem es la falta de SET, p.e.

set LastCell = wks.Cells.Find("*", wks.range("A1"), xlValues, xlWhole, xlByRows, xlPrevious, False) 

 

[chomsky]

también puede ser la falta de range("a1"). Pero sin duda un problem es la falta de set, p.e.

set lastcell = wks.cells.find("*", wks.range("a1"), xlvalues, xlwhole, xlbyrows, xlprevious, false) 

me sale el mismo error .

 

[sailepaty]

Intenta así,

set lastcell = wks.cells.find("*", , xlvalues, xlwhole, xlbyrows, xlprevious, false)

Saludos