Zellen einfärben wenn, 2 Tabellenblätter

Guten Tag,
ich bin VBA-technisch leider völlig aus der Übung und schaffe es nicht mir den richtigen Code zusammen zu stückeln.
Folgendes (hoffentlich versändlich formuliertes) Problem:
Ich habe zwei Tabellenblätter. In Tabellenblatt1, Spalte C, habe ich eine Auflistung von Kürzeln (z.B. "WB 1.01", "WB 1.02", "WB 3.05", "WB 8.23" etc.). Die genaue Anzahl kann variieren.
Jedes Kürzel hat seine eigene Farbe, soll heißen, die Zellen in denen die Kürzel stehen sind jeweils unterschiedlich eingefärbt.
In Tabellenblatt2 (Spalten D, L, T, AB) tauchen dieselben Kürzel wieder auf, in unvorhersehbarer Anzahl und Reihenfolge. Es ist auch möglich, dass ein Kürzel aus Tabellenblatt1 in Tabellenblatt2 nicht vorkommt.
Nun möchte ich den Kürzeln, bzw. den Zellen in denen sie stehen, in Tabellenblatt2 automatisch dieselben Farben zuweisen, die sie auch in Tabellenblatt1 haben.
Wie stell ich das am Geschicktesten an?
Vielen Dank,
Stephanie

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
Die Tabellen-Namen musst Du entsprechend anpassen


Option Explicit
Sub CopyColor()
Dim toColorRange As Range
Dim foundRange As Range
Dim i As Long
Dim toFind  As String
Dim myColor As Long
Dim firstAddress
' Den Range definieren der durchsucht werden soll
Set toColorRange = Range("Tabelle2!A:A,Tabelle2!C:C,Tabelle2!E:E")
Tabelle3.Activate ' Tabelle in der die Suchbegriffe stehen
For i = 1 To Cells(Rows.Count, 3).End(xlUp).Row  ' Geht die Werte in Spalte C durch
toFind = Cells(i, 3).Value  ' Spalte C
myColor = Cells(i, 3).Interior.ColorIndex  ' Spalte C
Set foundRange = toColorRange.Find(what:=toFind, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not (foundRange Is Nothing) Then
firstAddress = foundRange.Address
Do
foundRange.Interior.ColorIndex = myColor
Set foundRange = toColorRange.FindNext(foundRange)
Loop Until foundRange.Address = firstAddress
End If
Next i
End Sub

' liefert ein Range-Objekt mit der ersten Fundstelle im "ToColorRange" Set foundRange = toColorRange.Find(what:=toFind, LookIn:=xlValues, LookAt:=xlWhole, _ SearchOrder:=xlByRows, SearchDirection:=xlNext) ' Wenn nichts gefunden wurde ist das Range-Objekt "leer" d.h. "Nothing" If Not (foundRange Is Nothing) Then ' Da wir weitersuchen wollen müssen wir uns die erste Fundaddresse merken, da ' FindNext "im Kreis läuft", d.h. nach der letzten Fundstelle kommt wieder die Erste firstAddress = foundRange.Address ' Wir beginnen die Schleife (suche ALLE Vorkommen) Do ' Die gefunde Zelle wird neu gefärbt foundRange.Interior.Color = myColor ' Wir suchen das nächste Vorkommen Set foundRange = toColorRange.FindNext(foundRange) ' Wenn wir wieder die Erste Addresse bekommen sind wir fertig Loop Until foundRange.Address = firstAddress End If

Beliebteste Forumthreads (12 Monate)

Zellen einfärben wenn, 2 Tabellenblätter

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

321 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zellen einfärben wenn, 2 Tabellenblätter

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

321 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread