☰

使用 vba 选择所有具有突出显示单元格的行

tag-icon • tag-icon microsoft-excel vba
使用 vba 选择所有具有突出显示单元格的行

我很感激您能就我一直想解决的一个问题提供一些帮助。我有一份包含多个单元格的报告，其中一个单元格包含我们收到投诉通知的日期。我想要实现的是，在月初，我们复制并粘贴上个月的所有投诉。我所做的是录制一个宏，用浅红色突出显示所有包含上个月日期的单元格。但我的问题是，我测试了不同的代码变体，这些代码会选择突出显示单元格的整行，然后将其移动到另一个选项卡。下面是我尝试过的代码，但我希望它使用条件格式中添加的颜色来查找 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

答案1

以下是两个版本

  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

相关内容