Schraffieren einer Zelle
29.05.2006 12:05:27
Catweezle
Ein Arbeitskollege hat mir mal folgendes Makro geschrieben, mit dem ich eine Zelle schraffieren konnte, wenn in einer anderen Zelle derselben Zeile ein bestimmtes Kürzel auftaucht Kollege arbeitet nicht mehr bei uns, das Makro bräuchte eine Anpassung, könnt Ihr mir helfen?
Das Makro bewirkt, dass Zellen der Spalte BC rot schraffiert werden, sobald in einer anderen Zelle derselben Zeile die Kürzel "ws" oder "odws" auftauchen. Das funktioniert gut, ABER: Wenn ich das Kürzel "ws" oder "odws" entferne nimmt es die rote Schraffur nicht mehr weg. Wie kriege ich das auch noch hin?
Danke und Grüsse!
Heiko
Makro:
Option Explicit
Public
Sub CheckWS_WH()
On Error GoTo Fehler
Dim ALetzte, BLetzte, i As Long, j As Long
Dim hilf As String
Dim wb2 As Workbook
Dim wks2 As Worksheet
Dim k As Integer
Dim Bereich As Range
Application.ScreenUpdating = False
Set wb2 = ThisWorkbook
Set wks2 = wb2.Sheets("OA + OAss")
ALetzte = IIf(IsEmpty(wks2.Range("A65536")), wks2.Range("A65536").End(xlUp).Row, 65536)
For i = 8 To ALetzte
wks2.Cells(i, 55).Interior.Pattern = xlSolid
For k = 4 To 43
If LCase(wks2.Cells(i, k)) = "ws" Or LCase(wks2.Cells(i, k)) = "odws" Then
hilf = wks2.Cells(7, k)
If hilf = "" Then hilf = wks2.Cells(7, k - 1)
If hilf = "Du" Or hilf = "Kr" Then
Else
With wks2.Cells(i, 55).Interior
'.ColorIndex = 0
.Pattern = xlGray16
.PatternColorIndex = 7
End With
End If
End If
Next
If (Format(wks2.Cells(i, 2), "dd.mm") = "31.12") Then Exit For
Next
Application.ScreenUpdating = True
Exit Sub
Fehler:
MsgBox "Fehler" & vbLf & Err.Description
End Sub