☰

VBAを使用してセルが強調表示されているすべての行を選択します

tag-icon • tag-icon microsoft-excel vba
VBAを使用してセルが強調表示されているすべての行を選択します

解決しようとしている問題について、助けていただければ幸いです。複数のセルを含むレポートがあり、セルの 1 つに苦情の通知を受けた日付が含まれています。私が実現しようとしているのは、月の初めに前月のすべての苦情をコピーして貼り付けることです。私が行ったのは、前月の日付を含むすべてのセルを薄い赤で強調表示するマクロを記録することです。しかし、私の問題は、強調表示されたセルを含む行全体を選択し、それを別のタブに移動するさまざまなコードのバリエーションをテストしたことです。以下は私が試したコードですが、条件付き書式で追加された色を使用して列 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

以下に2つのバージョンがあります

  1. 1つ目は、日付のオートフィルターのみを使用して、すべての苦情を新しいシートにコピーすることです。
  2. 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

関連情報