HILFE - Heatmap Farbverlauf | HERBERS Excel Forum

Sonja · 2006-09-08T06:55:57+00:00

Hallo zusammen, ich habe folgendes Problem. Ich möchte in Excel im Rahmen eines Projektplans eine Heatmap je Projekt angeben (je Zeile). Eine Heatmap zeigt den Projektzustand an. Es gibt folgende Zustände: grün, grün-gelb, gelb, gelb-rot, rot. Die Ausgabe soll in einem normalen Feld (Kästchen) in einer Spalte bzw. pro Projekt was ich anzeige je Zeile angezeigt werden. Die Farben grün, gelb und rot sind einfach. Bei grün-gelb und gelb-rot hätte ich gerne so Verläufe wie man sie in Powerpoint in einem z.B. Feld verlaufen lassen kann. In den neuen Excelversion geht das. In 2000 habe ich es nicht gefunden. Ziel sollte sein, dass man in dem Feld eine Auswahl an 5 Zustände in Worten wie gelb, grün erhält. Danach soll sich das Feld entsprechend färben. Vielleicht gibt es ja auch eine Lösung mit VBA in der Art, das man in Powerpoint 5 Bilder abspeichert und über Excel je nach Auswahl dann lädt. Wäre toll wenn jemend eine Lösung parat hat. Falls es nicht geht, wie könnte ich die 5 Bilder via VBA nach Auswahl eines Textes laden ? Bitte um VBA code - Danke. Danke im Voraus Sonja

Hallo Sonja,
Füge folgende Code in ein Modul ein.
Jetzt kannst Du mit der Funktion =addHeatMap(HitzeNr, Zellenaddresse)
in einer Zelle bestimmen, wo ein ein Rechteck mit Deinen Farben gezeichnet werden soll, wobei: Hitzenummer 1-5 (grün bis rot) und Zelladresse wo das Rechteck gezeichnet werden soll.


Option Explicit
Public Function addHeatMap(iHeat As Integer, target As Range) As String
Dim sxTop, sxLeft, sxWidth, sxHeight As Double
Dim sShape As Shape
Dim bShapeExist As Boolean
Dim ixShape, ixColor1, ixColor2 As Integer
Application.Volatile
sxTop = target.Top
sxLeft = target.Left
For Each sShape In ActiveSheet.Shapes
ixShape = ixShape + 1
If sShape.Type = msoShapeRectangle And _
sShape.Top = sxTop And _
sShape.Left = sxLeft Then
bShapeExist = True
Exit For
End If
Next
sxHeight = target.RowHeight
sxWidth = target.Width
If bShapeExist Then ActiveSheet.Shapes(ixShape).Delete
ActiveSheet.Shapes.AddShape msoShapeRectangle, sxLeft, sxTop, sxWidth, sxHeight
ixShape = ActiveSheet.Shapes.Count
Select Case iHeat
Case 1
ixColor1 = 11
ixColor2 = 11
Case 2
ixColor1 = 13
ixColor2 = 11
Case 3
ixColor1 = 13
ixColor2 = 13
Case 4
ixColor1 = 10
ixColor2 = 13
Case 5
ixColor1 = 10
ixColor2 = 10
Case Else
addHeatMap = "Fehler Heat [1-5]"
End Select
ActiveSheet.Shapes(ixShape).Fill.ForeColor.SchemeColor = ixColor1
ActiveSheet.Shapes(ixShape).Fill.BackColor.SchemeColor = ixColor2
ActiveSheet.Shapes(ixShape).Fill.TwoColorGradient msoGradientVertical, 2
ActiveSheet.Shapes(ixShape).Line.Visible = msoFalse
addHeatMap = ""
End Function

Gruss Hansueli

Hallo Sonja,
Hier eine etwas verbesserte Version.
Parameter 2 ist optional, d.h. wenn weggelassen, wird die Heatmap in der Zelle angezeigt, in der die Funktion aufgerufen wird (z.B. =addHeatMap(2)), andernfalls in der Zelle die in Parameter 2 angegeben wird (z.B. =addHeatMap(3;D9) zeigt die Heatmap in Zelle D9.
Die Überprüfung, ob schon eine Heatmap existiert ist effizienter. Die Heat-Maps passen sich automatisch der Zellengrösse an.
Public


Function addHeatMap(iHeat As Integer, Optional target As Range) As String
Dim sxTop, sxLeft, sxWidth, sxHeight As Double
Dim tShapeName As String
Dim sShape As Shape
Dim bShapeExist As Boolean
Dim ixShape, ixColor1, ixColor2 As Integer
On Error Resume Next
Application.Volatile
If target Is Nothing Then Set target = Application.Caller
tShapeName = "hMap" & target.Row & target.Column
sxTop = target.Top
sxLeft = target.Left
sxHeight = target.RowHeight
sxWidth = target.Width
Select Case iHeat
Case 1
ixColor1 = 11
ixColor2 = 11
Case 2
ixColor1 = 13
ixColor2 = 11
Case 3
ixColor1 = 13
ixColor2 = 13
Case 4
ixColor1 = 10
ixColor2 = 13
Case 5
ixColor1 = 10
ixColor2 = 10
Case Else
addHeatMap = "#HeatMap p1 [1-5]"
Exit Function
End Select
ActiveSheet.Shapes(tShapeName).Delete
ActiveSheet.Shapes.AddShape msoShapeRectangle, sxLeft, sxTop, sxWidth, sxHeight
ixShape = ActiveSheet.Shapes.Count
ActiveSheet.Shapes(ixShape).Name = tShapeName
ActiveSheet.Shapes(ixShape).Fill.ForeColor.SchemeColor = ixColor1
ActiveSheet.Shapes(ixShape).Fill.BackColor.SchemeColor = ixColor2
ActiveSheet.Shapes(ixShape).Fill.TwoColorGradient msoGradientVertical, 2
ActiveSheet.Shapes(ixShape).Line.Visible = msoFalse
ActiveSheet.Shapes(ixShape).Placement = xlMoveAndSize
addHeatMap = ""
End Function

Gruss Hansueli

HILFE - Heatmap Farbverlauf

Forumthread: HILFE - Heatmap Farbverlauf

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Infobox / Tutorial

Heatmap Farbverlauf in Excel erstellen

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)