Hallo Mike,
die Aufgabe habe ich nicht komplett gelöst, aber soweit vorbereitet, dass die erste Bedingung erfüllt wird.
Manche Stellen sind hardcodiert - da darfst Du im zuge der weiteren Automatisierung ran. Habe so gut es geht kommentiert.
Option Explicit
Const m_sWksName As String = "qryPMAExcelDynamic"
Sub AutoFilterA()
Dim wks As Excel.Worksheet
Dim rng As Excel.Range, rngIntersect As Excel.Range
'Fehlerbehandlung
On Error GoTo FinishErr
'Referenz auf das Arbeitsblatt
Set wks = ThisWorkbook.Worksheets(m_sWksName)
With wks
'wenn ein Filter gesetzt -> diesen entfernen
If .AutoFilterMode Then .AutoFilterMode = False
'letzte beschriebene Zelle aus Spalte 1
'und letzte beschriebene Zelle in Zeile 1 ermitteln
'Hinweis: auf die prüfung ob die allerletzten Zellen in Spalte/Zeile1 beschrieben sind wird hier verzichtet
Set rng = .Range(.Cells(.Rows.Count, 1).End(xlUp), .Cells(1, .Columns.Count).End(xlToLeft)) 'ist in Zelle CL1 die Formel gewollt?
'Suche in Spalte H nach Datum grösser heute, in Spalte U nach "A" und ändere in Spalte AK den Text von "rot" nach "gelb"
rng.AutoFilter Field:=8, Criteria1:=">" & CLng(Now())
rng.AutoFilter Field:=21, Criteria1:="A"
'Alternativ nach RGB()-Farbcodierungrng.AutoFilter Field:=21, Criteria1:=RGB(255, 255, 0), Operator:=xlFilterCellColor
'Prüfen, ob das Filtrat, ausser der Überschrift, Daten enthält
'Wenn ja, dann nur die zu beschreibende Spalte in ein Range-Objekt isolieren und beschreiben
Set rngIntersect = Intersect(rng, rng.Offset(1), rng.SpecialCells(xlCellTypeVisible), rng.Columns("AK"))
If Not rngIntersect Is Nothing Then
rngIntersect.Value = "gelb"
End If
End With
FinishErr:
Select Case Err.Number
Case 0
Case 9 '#9: Index außerhalb des gültigen Bereichs
'Worksheet nicht vorhanden
MsgBox "Arbeitsblatt: " & m_sWksName & " nicht gefunden." & vbNewLine & "Vorgang abgebrochen.", vbCritical + vbOKOnly, "Autor informiert:"
Case Else
Debug.Print Err.Number & vbNewLine & Err.Description
End Select
'
Set rngIntersect = Nothing: Set rng = Nothing: Set wks = Nothing
End Sub
|