Выберите все строки, у которых выделена ячейка, используя vba

Question

Я был бы признателен за помощь по вопросу, который я пытался выяснить. У меня есть отчет с несколькими ячейками, одна из которых содержит дату, когда мы получили уведомление о жалобе. Я пытаюсь сделать так, чтобы в начале месяца мы копировали и обрабатывали все жалобы за предыдущий месяц. Я сделал запись макроса, который выделил бы все ячейки, содержащие дату предыдущих месяцев, красным цветом. Но мои проблемы заключаются в том, что я протестировал различные варианты кода, которые бы выделяли всю строку с выделенной ячейкой и затем перемещали ее на другую вкладку. Ниже приведен код, который я пробовал, но я хочу, чтобы он искал ячейки в столбце C того цвета, который был добавлен при условном форматировании.

Спасибо за помощь!

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

Ниже 2 версии

1. первый использует только автофильтр по датам, чтобы скопировать все жалобы на новый лист
2. вторая применяет условное форматирование сначала к столбцу C, а затем к автофильтру

---

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