bitte um Makrohilfe!
Wie kann per Auswahl den grünen Pfeil (Richtung unten) oder
den roten Pfeil (Richtung oben) in die aktive Zelle einfügen?
Vielen Dank
https://www.herber.de/bbs/user/75747.xls
Option Explicit
'Erstellt unter Excel 2007
'Code in allgemeinem Modul
Sub Aktiviere_Taste()
Application.OnKey "^{UP}", "'PfeilSetzen ""1""'"
Application.OnKey "^{DOWN}", "'PfeilSetzen ""2""'"
Application.OnKey "^{RIGHT}", "'PfeilSetzen ""3""'"
Application.OnKey "^{LEFT}", "'PfeilSetzen ""4""'"
End Sub
Sub DeAktiviere_Taste()
Application.OnKey "^{UP}"
Application.OnKey "^{DOWN}"
Application.OnKey "^{RIGHT}"
Application.OnKey "^{LEFT}"
End Sub
Public Sub Pfeilsetzen(lOption)
Select Case Val(lOption)
Case 1: Call EinfuegenPfeil(Zelle:=ActiveCell, lRichtung:=1, Farbe:=255) 'Pfeil oben - rot
Case 2: Call EinfuegenPfeil(Zelle:=ActiveCell, lRichtung:=2, Farbe:=6723891) 'Pfeil unten - _
grün
Case 3: Call EinfuegenPfeil(Zelle:=ActiveCell, lRichtung:=3, Farbe:=255) 'Pfeil rechts - _
rot
Case 4: Call EinfuegenPfeil(Zelle:=ActiveCell, lRichtung:=4, Farbe:=6723891) 'Pfeil links - _
grün
End Select
End Sub
Public Sub EinfuegenPfeil(Zelle As Range, lRichtung As Long, Farbe As Long)
Dim oPfeil As Shape, wks As Worksheet
Dim B_X#, B_Y#, E_X#, E_Y#, lFarbe As Long
Dim Laenge#
'Koordinaten der Linie, ermittelt aus Top- und Left-Position und Width der Zelle
'B_X = Beginn X
'E_X = Ende X
'B_Y = Beginn Y
'E_Y = Ende Y
With Zelle
Laenge = 16 'Länge der Pfeillinien
Select Case lRichtung
Case 1 'unten nach oben
B_X = .Left + .Width - 1: B_Y = .Top + .Height - 1
E_X = B_X: E_Y = B_Y - Laenge
Case 2 'oben nach unten
B_X = .Left + .Width - 1: B_Y = .Top + 1
E_X = B_X: E_Y = B_Y + Laenge
Case 3 'links nach rechts
B_X = .Left + .Width - 1 - Laenge: B_Y = Zelle.Top + .Height / 2
E_X = B_X + Laenge: E_Y = B_Y
Case 4 'rechts nach links
B_X = .Left + .Width - 1: B_Y = .Top + .Height / 2
E_X = B_X - Laenge: E_Y = B_Y
End Select
End With
Set wks = Zelle.Parent
Set oPfeil = wks.Shapes.AddLine(BeginX:=B_X, BeginY:=B_Y, EndX:=E_X, EndY:=E_Y)
With oPfeil
.Placement = xlMove 'Pfeil an Zelle gebunden
With .Line
'Form und Größe der Pfeile
.BeginArrowheadStyle = 1 'msoArrowheadNone
.EndArrowheadStyle = 2 'msoArrowheadTriangle
.EndArrowheadLength = 3 'msoArrowheadLong
.EndArrowheadWidth = 3 'msoArrowheadWide
.Weight = 1 'Linienbreite
'Farbe der Linie
.ForeColor.RGB = Farbe
End With
End With
Set wks = Nothing: Set oPfeil = Nothing
End Sub