Anzeige
Archiv - Navigation
768to772
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
768to772
768to772
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Schraffieren einer Zelle

Schraffieren einer Zelle
29.05.2006 12:05:27
Catweezle
Hallo!
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

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Schraffieren einer Zelle
29.05.2006 14:26:25
Franz
Hallo Heiko,
starte das Makro noch einmal nachdem die ws bzw. odws entfernt wurden. Dann wird das Format auf das in dieser Zeile definierte Format zurückgesetzt:

For i = 8 To ALetzte
wks2.Cells(i, 55).Interior.Pattern = xlSolid
For k = 4 To 43

Falls die Anpassung des Formats beim Löschen von ws bzw. odws-Einträgen immer sofort passieren soll, dann muss du folgendes Makro unter der Tabelle im VBA-Editor einfügen. Es wird dann jeweils die Zeile überprüft in der Änderungen gemacht werden

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Column >= 4 And Target.Column <= 43 And Target.Row >= 8 Then
On Error GoTo Fehler
Dim 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")
i = Target.Row
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
Application.ScreenUpdating = True
Exit Sub
Fehler:
MsgBox "Fehler" & vbLf & Err.Description
End If
End Sub

Gruß
Franz
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige
Archiv - Verwandte Themen
Forumthread
Beiträge