Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1308to1312
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
Inhaltsverzeichnis

Farbe in einem Arbeitsblatt per Makro ändern

Farbe in einem Arbeitsblatt per Makro ändern
06.05.2013 12:18:27
KLE
Hallo,
...habe eine Excel-Mappe mit vielen Blättern und jedes hat einen Grundfarbton, nur in unterschiedlichen Helligkeiten. D.h. in dem einen Blatt ist alles ROT, das andere BLAU etc.
Ich möchte nun gern die Farben auf einem Excel-Blatt per Marko (klick) ändern. D.h. ich gebe vor, welche Farbe mit welcher ausgetauscht werden soll. Unabhängig ob es sich um eine Schrift, Rahmen, Farbfläche etc. handelt.
Dachte ich hinterlege A1 mit der "neuen" Farbe und die A2 mit der "alten" Farbe, welche nun durch die neue ausgetauscht werden soll...aber wie kann ich es für Rahmen, Schrift etc. machen - d.h. wie lautet ein VBA-Befehl dafür, nach einer Formatierung zu suchen, die der Farbe von A2 entspricht und diese mit A1-Farbton austauscht? Bekomme es irgendwie nicht hin...
Wie kann ich das tun?
Brauche Eure Hilfe...
Super vielen lieben Dank!
KLE

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Farbe in einem Arbeitsblatt per Makro ändern
06.05.2013 14:26:36
fcs
Hallo KLE,
die austauschende Farbe für die Schrift und den Rahmen kannst du auch an den Zellen A1 und A2 einstellen,wobei in meinem Makrobeispiel die Farbe von der unteren Rahmenlinie genommen wird.
Gruß
Franz
Sub FarbenAendern()
Dim wks As Worksheet, rngZelle As Range, objBorder As Border
Dim InteriorFarbeAlt As Long, InteriorFarbeNeu As Long
Dim FontFarbeAlt As Long, FontFarbeNeu As Long
Dim BorderFarbeAlt As Long, BorderFarbeNeu As Long
Set wks = ActiveSheet
With wks
With .Range("A1")
InteriorFarbeNeu = .Interior.Color
FontFarbeNeu = .Font.Color
BorderFarbeNeu = .Borders(xlEdgeBottom).Color
End With
With .Range("A2")
InteriorFarbeAlt = .Interior.Color
FontFarbeAlt = .Font.Color
BorderFarbeAlt = .Borders(xlEdgeBottom).Color
End With
For Each rngZelle In .UsedRange.Cells
With rngZelle
Select Case rngZelle.Address
Case "$A$1", "$A$2"
Case Else
If .Interior.Color = InteriorFarbeAlt Then .Interior.Color = InteriorFarbeNeu
If .Font.Color = FontFarbeAlt Then .Font.Color = FontFarbeNeu
For Each objBorder In rngZelle.Borders
If objBorder.Color = BorderFarbeAlt Then objBorder.Color = BorderFarbeNeu
Next
End Select
End With
Next
End With
End Sub

Anzeige
Musterdatei dabei, zum besseren Verständnis...
07.05.2013 08:38:34
KLE
Guten Morgen Franz,
...vielen Dank! Leider klappt es noch nicht so richtig. Die Rahmen werden mit der Version komplett gezeichnet. D.h. incl. der "Kreuze", Diagonalen und nicht nur die, die vorhanden sind. Aber ich versuche mich mal daran, diesen Code dahingehend umzuschreiben...
Auch werden alle Zellen, selbst wenn Sie vorher keine Farbe hatten - nun farbig?!
Aber mit Hilfe Deines Codes, habe ich eine Ausgangsbasis, auf der ich es weiter versuchen kann...Danke!
Habe eine Mustertabelle mal hochgeladen, vielleicht hilft die dem einen oder anderen, meinen Wunsch besser zu verstehen - anders, wie ich ihn formuliert habe, um die Lösung schneller zu finden - für die ich bestimmt einige Tage brauchen werde...
Musterdatei, zum besseren Verständnis:
https://www.herber.de/bbs/user/85220.xlsx
Vielen Dank an Dich Franz für den ersten Schritt zur Lösung! und allen anderen, die mir weiterhelfen können!!!
Sonnige Grüße
KLE

Anzeige
AW: Musterdatei dabei, zum besseren Verständnis...
08.05.2013 10:44:34
UweD
Hallo Franz
Ist schon Alt, aber hier eine Lösung.
Im Intersect Bereich habe ich die Zellen ausgespart, kannst du anpassen.

Option Explicit
Sub Fabtausch()
On Error GoTo Fehler
Dim TB, Zelle
Dim AltFarb1, NeuFarb1, AltFarb2, NeuFarb2, AltFarb3, NeuFarb3
Set TB = ActiveSheet
Application.ScreenUpdating = False
With TB
AltFarb1 = .Range("A1").Interior.Color: NeuFarb1 = .Range("C1").Interior.Color
AltFarb2 = .Range("A2").Interior.Color: NeuFarb2 = .Range("C2").Interior.Color
AltFarb3 = .Range("A3").Interior.Color: NeuFarb3 = .Range("C3").Interior.Color
For Each Zelle In TB.UsedRange.Cells
If Intersect(Zelle, Range("A1:B3")) Is Nothing Then ' Ausgegrenzter Bereich
With Zelle.Interior
'Zellfarbe
If .Color = AltFarb1 Then .Color = NeuFarb1
If .Color = AltFarb2 Then .Color = NeuFarb2
If .Color = AltFarb3 Then .Color = NeuFarb3
End With
With Zelle.Font
'Zelltext
If .Color = AltFarb1 Then .Color = NeuFarb1
If .Color = AltFarb2 Then .Color = NeuFarb2
If .Color = AltFarb3 Then .Color = NeuFarb3
End With
With Zelle.Borders(xlEdgeLeft)
'Rahmen
If .Color = AltFarb1 Then .Color = NeuFarb1
If .Color = AltFarb2 Then .Color = NeuFarb2
If .Color = AltFarb3 Then .Color = NeuFarb3
End With
With Zelle.Borders(xlEdgeRight)
If .Color = AltFarb1 Then .Color = NeuFarb1
If .Color = AltFarb2 Then .Color = NeuFarb2
If .Color = AltFarb3 Then .Color = NeuFarb3
End With
With Zelle.Borders(xlEdgeTop)
If .Color = AltFarb1 Then .Color = NeuFarb1
If .Color = AltFarb2 Then .Color = NeuFarb2
If .Color = AltFarb3 Then .Color = NeuFarb3
End With
With Zelle.Borders(xlEdgeBottom)
If .Color = AltFarb1 Then .Color = NeuFarb1
If .Color = AltFarb2 Then .Color = NeuFarb2
If .Color = AltFarb3 Then .Color = NeuFarb3
End With
End If
Next
End With
Err.Clear
Fehler:
If Err.Number  0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub
Gruß UweD

Anzeige
AW: Musterdatei dabei, zum besseren Verständnis...
08.05.2013 13:09:22
fcs
Hallo KLE,
ich hab mein Makro mal etwas in deine Wunschrichtung modifiziert, so dass in deinem Musterblatt das gewünschte Ergebnis generiert wird.
In meiner Testdatei wurden bei den Rahmen nur die bereits farbigen Rahmen geändert, aber keine weiteren Rahmen sichtbar. Warum: ?
Gruß
Franz
Sub FarbenAendern()
Dim wks As Worksheet, rngZelle As Range, objBorder As Border
Dim InteriorFarbeAlt As Long, InteriorFarbeNeu As Long
Dim FontFarbeAlt As Long, FontFarbeNeu As Long
Dim BorderFarbeAlt As Long, BorderFarbeNeu As Long, Zeile As Long
Set wks = ActiveSheet
With wks
'Farbewerte Neu und Atl in Zeilen 2 bis 4 abarbeiten
Application.ScreenUpdating = False
For Zeile = 2 To 4
With .Cells(Zeile, 1)
InteriorFarbeAlt = .Interior.Color
FontFarbeAlt = .Interior.Color
End With
With .Cells(Zeile, 3)
InteriorFarbeNeu = .Interior.Color
FontFarbeNeu = .Interior.Color
BorderFarbeNeu = .Interior.Color
End With
For Each rngZelle In .UsedRange.Cells
With rngZelle
Select Case rngZelle.Address
Case "$A$2", "$C$2", "$A$3", "$C$3", "$A$4", "$C$4"
'vorgabezellen überspringen
Case Else
If .Interior.Color = InteriorFarbeAlt Then .Interior.Color = InteriorFarbeNeu
If .Font.ColorIndex = xlAutomatic Or .Font.Color = 16777215 Then
'do nothing
Else
If .Font.Color = FontFarbeAlt Then .Font.Color = FontFarbeNeu
End If
If Zeile = 2 Then 'Bei Rahmen nut Hauptfarbe neu setzen
For Each objBorder In rngZelle.Borders
With objBorder
If .LineStyle  xlLineStyleNone Then
.Color = BorderFarbeNeu
End If
End With
Next
End If
End Select
End With
Next
Next Zeile
Application.ScreenUpdating = True
End With
End Sub

Anzeige
Perfekt ;o) ...super vielen Dank!!! o.T.
09.05.2013 18:26:25
KLE

61 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige