HILFE - Heatmap Farbverlauf | HERBERS Excel Forum

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

Function addHeatMap(iHeat As Integer, Optional target As Range) As String Dim tShapeName As String 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 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, target.Left, target.Top, target.Width, target.RowHeight 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

Beliebteste Forumthreads (12 Monate)

HILFE - Heatmap Farbverlauf

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

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread