對於我一直試圖解決的問題,我希望得到一些幫助。我有一份包含多個儲存格的報告,其中一個儲存格包含我們收到投訴通知的日期。我想要完成的是,在月初,我們複製並過去上個月的所有投訴。我所做的是記錄一個宏,該宏將以淺紅色突出顯示包含前幾個月日期的所有單元格。但我的問題是,我測試了不同的程式碼變體,這些程式碼會選擇突出顯示單元格的整行,然後將其移至另一個選項卡。下面是我嘗試過的程式碼,但我希望它在 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個版本
- 第一個是僅使用日期自動篩選器將所有投訴複製到新工作表
- 第二個先對 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