Ich versuche es.
Ich bin eine Abwesenheitsübersicht am basteln. dort habe ich ein Tabellenblatt : Grundeinstellungen und dann Tabellenblätter für die Monate Jan. - Dez..
In dem Tabellenblatt Grundeinstellungen habe ich das Jahr stehen, Feiertage und eine Liste mit Abwesenheitskürzeln z.B. :
L |
Eintrag löschen |
U. |
Urlaub geplant |
bis zu 25 Stück. Diesen habe ich Bereichsnamen gegeben. Links AbwKk1-25 und rechts AbwK1-25. Jetzt rufe ich mit dem oben geschriebenen Code, wenn ich rechtsklicke das Kontextmenü auf welches mir dann anzeigt die ganzen ausgeschriebenen Beschreibungen und wenn ich was auswähle werden die passenden Abkürzungen eingefügt( mit Formatierung).
Dabei ist mir aufgefallen das ich bei Eintrag löschen jetzt das Feld clearen möchte und z.b. bei Bemerkung setzen ein Kommentar setzen möchte. Das funktioniert aber nicht mit meinem obengenanntem Code.
Hier noch einmal der Code der Funktionen:
Public Sub CreateCommandBar()
Dim objCommandBar As CommandBar
Dim objCommandBarButton As CommandBarButton
Dim objName As Name
Dim lngIndex As Long
Call DeleteCommandBar
Set objCommandBar = CommandBars.Add(Name:=CONTEXT_MENU, _
Position:=msoBarPopup, Temporary:=True)
For lngIndex = 1 To 25
For Each objName In ThisWorkbook.Names
If objName.Name = "AbwK" & CStr(lngIndex) Then Exit For
Next
If Not objName Is Nothing Then
If Not IsError(Evaluate(objName.RefersTo)) Then
If Not IsEmpty(Range(objName.Name).Value) Then
Set objCommandBarButton = objCommandBar.Controls.Add(Type:=msoControlButton)
With objCommandBarButton
.Caption = Range(objName.Name).Value
.OnAction = "'Färbe """ & Replace$(objName.Name, "K", "Kk") & """'"
End With
End If
End If
End If
Next
Set objCommandBarButton = Nothing
Set objCommandBar = Nothing
Set objName = Nothing
End Sub
Public Sub DeleteCommandBar()
Dim objCommandBar As CommandBar
For Each objCommandBar In CommandBars
If objCommandBar.Name = CONTEXT_MENU Then objCommandBar.Delete
Next
End Sub
Sub Färbe(ByVal sBereich As String)
Dim rng As Excel.Range
ActiveSheet.Protect Password:="KdoSAN", userinterfaceonly:=True
For Each rng In Selection
With rng
.Interior.Color = Application.Names(sBereich).RefersToRange.Interior.Color
.Value = Application.Names(sBereich).RefersToRange.Value
End With
Next
End Sub
Hoffe das ganze ist noch ein wenig klarer geworden =).
MfG SmileStyle
|