Seleccione todas las filas que tienen una celda resaltada usando vba

Question

Agradecería ayuda sobre un problema que he estado tratando de resolver. Tengo un informe con varias celdas y una de las celdas contiene la fecha en que recibimos la notificación de una queja. Lo que intento lograr es que a principios de mes copiemos y pasemos todas las quejas del mes anterior. Lo que hice fue grabar una macro que resaltaría en rojo claro todas las celdas que contienen la fecha del mes anterior. Pero mi problema es que he probado diferentes variaciones de código que seleccionarían la fila completa que tiene una celda resaltada y luego la moverían a otra pestaña. A continuación se muestra el código que probé pero quiero que busque las celdas en la columna C con el color que se agregó en el formato condicional.

¡Gracias por la ayuda!

Sub Test()
Dim wks As Worksheet
Dim wNew As Worksheet
Dim lRow As Long
Dim x As Long

  Columns("C:C").Select

    Selection.FormatConditions.Add Type:=xlTimePeriod, DateOperator:= _
        xlLastMonth
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
        With Selection.FormatConditions(1).Font
            .Color = -16383844
            .TintAndShade = 0
        End With
        With Selection.FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 13551615
            .TintAndShade = 0
        End With
    Selection.FormatConditions(1).StopIfTrue = False

  Set wks = ActiveSheet
  lRow = wks.Cells.SpecialCells(xlCellTypeLastCell).Row
  Set wNew = Worksheets.Add
  For x = 1 To lRow
    If wks.Cells(x, 1).Interior.Color = vbRed Then
      wks.Cells(x, 1).EntireRow.Copy wNew.Cells(x, 1)
    End If
  Next

End Sub

Answer 1

A continuación se muestran 2 versiones.

1. el primero es usar solo un Autofiltro en Fechas para copiar todas las quejas en una hoja nueva
2. el segundo aplica formato condicional a la columna C primero, luego Autofiltro en color

---

Option Explicit

Public Sub GetPreviousMonthsComplaintsFilterOnly()
    Const DATE_COL = 3  'C
    Dim wsSrc As Worksheet, wsDst As Worksheet
    Dim wsName As String, ur As Range

Application.ScreenUpdating = False  'set complaints ws name like: "Complaints - 2017-Sep"

    wsName = CleanWsName("Complaints - " & Format(DateAdd("m", -1, Now), "yyyy-mmm"))

    Set wsSrc = ThisWorkbook.Worksheets("Sheet1")   'report with all dates
    Set wsDst = GetComplaintsWs(wsName)             'complaints Worksheet
    wsDst.Name = wsName                             'rename the new complaints report

    With wsSrc.UsedRange
        If wsSrc.AutoFilterMode Then .AutoFilter    'clear previous filters

        .AutoFilter Field:=DATE_COL, Criteria1:=xlFilterLastMonth, Operator:=xlFilterDynamic

        'copy only if there are visible rows
        If .Columns(DATE_COL).SpecialCells(xlCellTypeVisible).CountLarge > 1 Then
            Set ur = wsSrc.UsedRange
            If Not IsDate(.Cells(1, DATE_COL)) Then
                Set ur = .Offset(1).Resize(.Rows.Count - 1, .Columns.Count)
            End If
            ur.Copy wsDst.Cells(wsDst.Cells(wsDst.Rows.Count, 1).End(xlUp).Row + 1, 1)

            wsDst.UsedRange.Columns.AutoFit
        End If
        .AutoFilter
        'wsSrc.Activate
    End With
Application.ScreenUpdating = True
End Sub

---

Public Sub GetPreviousMonthsComplaintsConditionalFormat()
    Const DATE_COL = 3   'C
    Dim wsSrc As Worksheet, wsDst As Worksheet, wsName As String, ur As Range
    Dim lRed As Long, dRed As Long

    lRed = RGB(255, 199, 206)       'or  13551615 (light red)
    dRed = RGB(156, 0, 6)           'or -16383844 (dark red)
Application.ScreenUpdating = False  'set complaints ws name like: "Complaints - 2017-Sep"
    wsName = CleanWsName("Complaints - " & Format(DateAdd("m", -1, Now), "yyyy-mmm"))
    Set wsSrc = ThisWorkbook.Worksheets("Sheet1")       'report with all dates
    Set wsDst = GetComplaintsWs(wsName):    wsDst.Name = wsName
    With wsSrc.UsedRange
        With .Columns(DATE_COL) 'apply conditional formatting to column C
            .FormatConditions.Delete
            .FormatConditions.Add Type:=xlTimePeriod, DateOperator:=xlLastMonth
            .FormatConditions(.FormatConditions.Count).SetFirstPriority
            .FormatConditions(1).Font.Color = dRed
            .FormatConditions(1).Interior.Color = lRed
            .FormatConditions(1).StopIfTrue = False
        End With
        If wsSrc.AutoFilterMode Then .AutoFilter
        .AutoFilter Field:=DATE_COL, Criteria1:=lRed, Operator:=xlFilterCellColor
    'or .AutoFilter Field:=DATE_COL, Criteria1:=dRed, Operator:=xlFilterFontColor
        If .Columns(DATE_COL).SpecialCells(xlCellTypeVisible).CountLarge > 1 Then
            Set ur = wsSrc.UsedRange
            If Not IsDate(.Cells(1, DATE_COL)) Then 'determine if first row are headers
                Set ur = .Offset(1).Resize(.Rows.Count - 1, .Columns.Count)
            End If
            ur.Copy wsDst.Cells(wsDst.Cells(wsDst.Rows.Count, 1).End(xlUp).Row + 1, 1)
            wsDst.UsedRange.Columns.AutoFit
            wsDst.UsedRange.Columns(DATE_COL).FormatConditions.Delete
        End If:    .Columns(DATE_COL).FormatConditions.Delete:    .AutoFilter
    End With
Application.ScreenUpdating = True
End Sub

---

Public Function GetComplaintsWs(ByVal wsName As String) As Worksheet
    Dim ws As Worksheet
    With ThisWorkbook
        For Each ws In ThisWorkbook.Worksheets
            If ws.Name = wsName Then Set GetComplaintsWs = ws
        Next
        If GetComplaintsWs Is Nothing Then
            Set GetComplaintsWs = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
        End If
    End With
End Function

Public Function CleanWsName(ByVal wsName As String) As String
    Const X = vbNullString
    wsName = Trim$(wsName)    'Trim, remove [ ] / \ : ? * ., and resize to len <= 31
    wsName = Replace(Replace(wsName, "[", X), "]", X)
    wsName = Replace(Replace(Replace(wsName, "/", X), "\", X), ":", X)
    wsName = Replace(Replace(Replace(wsName, "?", X), "*", X), ".", X)
    CleanWsName = Left$(wsName, 31)
End Function