PDA

Vollständige Version anzeigen : Hintergrundfarbe einer Zelle suchen und übernehmen.


Taifal
15.09.2011, 12:02
Guten Morgen!

Ich suche ein Makro das eine Nummer von der Tabelle1 Zelle A1 in der Tabelle2 Spalte A sucht und die Hintergrundfarbe der gesuchten Nummer in Tabelle1 A1 übernimmt.

Ich hoffe ihr könnt mir helfen, Danke im Voraus.

only Coding
15.09.2011, 13:01
Halo, Taifal,

aus der Range-Find-Methode und dem aufgezeichneten Code des Makro-Rekorders für eine Farbveränderung lässt sich folgende Prozedur erstellen:

Sub test2010()
Dim c As Range

With Worksheets(2).Range("A1:A500")
Set c = .Find(Range("A1").Text, LookIn:=xlValues)
If Not c Is Nothing Then
With Range("A1").Interior
.Pattern = c.Interior.Pattern
.PatternColorIndex = c.Interior.PatternColorIndex
.ThemeColor = c.Interior.ThemeColor
.TintAndShade = c.Interior.TintAndShade
.PatternTintAndShade = c.Interior.PatternTintAndShade
End With
End If
End With
End Sub
Einfacher war es da bis Excle2003:

Sub test2003()
Dim c As Range

With Worksheets(2).Range("A1:A500")
Set c = .Find(Range("A1").Text, LookIn:=xlValues)
If Not c Is Nothing Then
Range("A1").Interior.ColorIndex = c.Interior.ColorIndex
End If
End With
End Sub
HTH
only Coding

Taifal
16.09.2011, 01:15
Der erste Code geht bei mir leider nicht aber der zweite ist genau das was ich gesucht habe DANKE!

Taifal
17.09.2011, 12:06
Hallo!

Hab da noch ein zwei kleine Probleme.
Wenn ich z.b. 34 eingebe die Zahl aber nicht in der Tabelle vorhanden ist wird die erstbeste Nummer die mit der 34 anfängt z.b. 340128 hergenommen.
Die Zelle sollte dann aber Weiß bleiben.
Ist es möglich wenn ich eine schwarze Zelle hab das die Zahl dann in Weiß geschrieben wird?

Und ich kann mein Blatt nicht schützen, denn wenn ich das mach funktioniert das Makro nicht mehr. :(

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Color
End Sub


und deinen..

Sub Color()

Dim c As Range

With Worksheets(2).Range("A1:A500")
Set c = .Find(Range("A3").Text, LookIn:=xlValues)
If Not c Is Nothing Then
Range("A3").Interior.ColorIndex = c.Interior.ColorIndex
End If
End With
End Sub

Lg Taifal

only Coding
17.09.2011, 14:05
Hallo, Taifal,

die Einschränkung der Suche kann durch eine weitere Verwendung für den Find-Befehl errreicht wird, indem dort nämlich für LookAt der gesamte Inhalt der Zelle per xlWhole überprüft wird.

Als Präfix hast Du 2010 angegeben, aber den Code für 2003 verwendet. Im Kompatibilitätsmodus für Excel2010 kann es Probleme mit den Farbangaben geben. Da ist ggf. die Farbangabe durch den Makro-Rekorder herauszufinden und einzusetzen (oder aber vom RGB-Wert auszugehen).

Sub Taifal_2003_110917()

Dim rngHit As Range

With Worksheets(2).Range("A1:A500")
Set rngHit = .Find(Range("A1").Text, LookIn:=xlValues, LookAt:=xlWhole)
If Not rngHit Is Nothing Then
Range("A1").Interior.ColorIndex = rngHit.Interior.ColorIndex
End If
End With

With Range("A1")
If .Interior.ColorIndex = 1 Then ' 1 entspricht auf bei der Standardfarbpalette schwarz
.Font.ColorIndex = 2 ' 2 enstspricht weiß
Else
.Font.ColorIndex = xlColorIndexAutomatic
End If
End With

Set rngHit = Nothing

End Sub
Als Auslöser habe ich hinter der Tabelle1 den folgenden Code verwendet, der das Makro automatisch nach Änderung oder Bearbeitung in A1 startet:

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("A1")) Is Nothing Then
Taifal_2003_110917
End If

End Sub
HTH
only Coding

only Coding
17.09.2011, 14:12
Hallo, Taifal,

zum Schutz für die Tabelle1: für die Zelle A1 den Haken unter Zellen formatieren / Schutz / Gesperrt rausnehmen, dann im Workbook_Open-Ereignis bei DieseArbeitsmappe den folgenden Code verwenden:

Private Sub Workbook_Open()

Sheets("Tabelle1").Protect Password:="Passwort", UserInterfaceOnly:=True

End Sub
Codeausführung wird dadurch auf Tabelle1 zugelassen.

Gruß
only Coding

Taifal
19.09.2011, 20:38
Super, Herzlichen Dank ! :)