Wählen Sie alle Zeilen aus, in denen eine Zelle mit VBA hervorgehoben ist

Question

Ich wäre für Hilfe bei einem Problem dankbar, das ich zu lösen versuche. Ich habe einen Bericht mit mehreren Zellen und eine der Zellen enthält das Datum, an dem wir über eine Beschwerde benachrichtigt wurden. Ich versuche, am Anfang des Monats alle Beschwerden des vorherigen Monats zu kopieren und einzufügen. Ich habe ein Makro aufgezeichnet, das alle Zellen, die ein Datum des vorherigen Monats enthalten, hellrot hervorhebt. Mein Problem ist jedoch, dass ich verschiedene Codevarianten getestet habe, die die gesamte Zeile mit einer hervorgehobenen Zelle auswählen und sie dann auf eine andere Registerkarte verschieben. Unten ist der Code, den ich ausprobiert habe, aber ich möchte, dass er nach den Zellen in Spalte C mit der Farbe sucht, die bei der bedingten Formatierung hinzugefügt wurde.

Danke für die Hilfe!

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

Unten sind 2 Versionen

1. Die erste Möglichkeit besteht darin, nur einen Autofilter für Daten zu verwenden, um alle Beschwerden in ein neues Blatt zu kopieren.
2. Der zweite wendet zuerst die bedingte Formatierung auf Spalte C an, dann den AutoFilter auf Farbe

---

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