Bedingte Formatierung mit S-Verweis

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub a() Dim Wb As Workbook: Set Wb = ThisWorkbook Dim WsTemp As Worksheet: Set WsTemp = Wb.Worksheets("Vorgänge") Dim WsAct As Worksheet, r As Range, c As Range Dim rSearch As Range, f Application.ScreenUpdating = False Set WsAct = ActiveSheet With WsTemp Set rSearch = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)) End With With WsAct Set r = .Range(.Cells(1, 6), _ .Cells(.Rows.Count, 6).End(xlUp)) For Each c In r f = Application.Match(c.Text, rSearch, 0) If Not IsError(f) Then c.Offset(, -1).Interior.Color = _ rSearch(f).Interior.Color End If Next c End With Set Wb = Nothing: Set WsTemp = Nothing: Set WsAct = Nothing Set r = Nothing: Set c = Nothing: Set rSearch = Nothing End Sub

Sub a() Dim Wb As Workbook: Set Wb = ThisWorkbook Dim WsTemp As Worksheet: Set WsTemp = Wb.Worksheets("Vorgänge") Dim WsAct As Worksheet, r As Range, c As Range Dim rSearch As Range, f Application.ScreenUpdating = False Set WsAct = ActiveSheet With WsTemp Set rSearch = .Range(.Cells(1, 1), _ .Cells(.Rows.Count, 1).End(xlUp)) End With With WsAct Set r = .Range(.Cells(1, 6), _ .Cells(.Rows.Count, 6).End(xlUp)) For Each c In r f = Application.Match(c, rSearch, 0) If Not IsError(f) Then c.Offset(, -1).Interior.Color = _ rSearch(f).Interior.Color End If Next c End With Set Wb = Nothing: Set WsTemp = Nothing: Set WsAct = Nothing Set r = Nothing: Set c = Nothing: Set rSearch = Nothing End Sub

Hi!
Bitte künftig bei Fragen in Foren alle Anforderungen gleich beim ersten Beitrag anführen; es kann durchaus sein, dass ein Code komplett umgearbeitet werden muss, wenn nach und nach neue Infos bzw. Anforderungen nachgefragt werden, und das schafft ggf. Unmut.
Bzgl. Deiner Erweiterung: Hab den Code ergänzt, jetzt wird auch geprüft ob die jew. Zelle in F:Fx leer ist oder nicht, wenn sie leer ist, wird die Füllfarbe aus Ex entfernt, wenn nicht, erfolgt die Prüfung auf Vorgänge!A1:Ax und die Färbung, wie bisher:


Sub a()
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim WsTemp As Worksheet: Set WsTemp = Wb.Worksheets("Vorgänge")
Dim WsAct As Worksheet, r As Range, c As Range
Dim rSearch As Range, f
Application.ScreenUpdating = False
Set WsAct = ActiveSheet
With WsTemp
Set rSearch = .Range(.Cells(1, 1), _
.Cells(.Rows.Count, 1).End(xlUp))
End With
With WsAct
Set r = .Range(.Cells(1, 6), _
.Cells(.Rows.Count, 6).End(xlUp))
For Each c In r
Select Case True
Case c.Value = ""
c.Offset(, -1).Interior.Pattern = xlNone
Case Else
f = Application.Match(c, rSearch, 0)
If Not IsError(f) Then
c.Offset(, -1).Interior.Color = _
rSearch(f).Interior.Color
End If
End Select
Next c
End With
Set Wb = Nothing: Set WsTemp = Nothing: Set WsAct = Nothing
Set r = Nothing: Set c = Nothing: Set rSearch = Nothing
End Sub

Hoffe das passt, ich bin für heute raus ;-), viel Erfolg und ein frohes Fest!
Michael

Beliebteste Forumthreads (12 Monate)

Bedingte Formatierung mit S-Verweis

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bedingte Formatierung mit S-Verweis

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread