Unicodezeichen in eine Zelle einfügen

Beispieldatei (Unicodedialog.zip 14 kB)

Unicodezeichen lassen sich in einer Zelle eines Tabellenblattes darstellen. Dazu muss ein Unicodezeichensatz wie der von Microsoft Office "Arial Unicode MS" installiert sein.

Leider lassen sich die Zeichen nur über den Umweg Zwischenablage einfügen, eine Lösung wie beispielsweise die mit Alt und der Eingabe von 065 auf der numerischen Tastatur gibt es nicht.

Mit ein paar  Prozeduren kann man dem abhelfen. Folgender Code fügt dem Kontextmenü >Cell< zwei Menüpunkte hinzu. In den zwei zugehörigen Prozeduren kann man den Zeichencode als Hex- oder als Dezimalstring eingeben, der fertige Unicodestring wird in die Aktive Zelle eingefügt.

Damit diese Menüpunkte auch wieder verschwinden, werden sie in der Ereignisprozedur >Workbook_BeforeClose< entfernt und in der >Workbook_Open< neu gesetzt. Diese Prozeduren werden in das Klassenmodul >DieseArbeitsmappe< eingefügt. Der Rest kommt in ein allgemeines Modul.

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim objCommandBarButton As CommandBarButton
    On Error Resume Next
    With Application.CommandBars("Cell")
      For Each objCommandBarButton In .Controls
         With objCommandBarButton
            If .Tag = "Unicodedialog Dezimal" Or _
               .Tag = "Unicodedialog Hex" Then .Delete
         End With
      Next
   End With
End Sub


Private Sub Workbook_Open()
   KontextmenüErgänzen
End Sub

' In ein Modul

Option Explicit
Private Declare Function MessageBox Lib "user32" _
    Alias "MessageBoxW" ( _
    ByVal hwnd As Long, _
    ByVal lpText As Long, _
    ByVal lpCaption As Long, _
    ByVal wType As Long _
    ) As Long

Public Sub KontextmenüErgänzen()
Dim objCommandBarButton As CommandBarButton
    On Error Resume Next
    With CommandBars("Cell")
      For Each objCommandBarButton In .Controls
         With objCommandBarButton
            If .Tag = "Unicodedialog Dezimal" Or _
               .Tag = "Unicodedialog Hex" Then .Delete
         End With
      Next
      Set objCommandBarButton = .Controls.Add(msoControlButton)
      With objCommandBarButton
         .Caption = "Unicodedialog Dezimal"
         .OnAction = "UnicodedialogDez"
         .Tag = "Unicodedialog Dezimal"
         .Move before:=1
      End With
      Set objCommandBarButton = .Controls.Add(msoControlButton)
      With objCommandBarButton
         .Caption = "Unicodedialog Hex"
         .OnAction = "UnicodedialogHez"
         .Tag = "Unicodedialog Hex"
         .Move before:=1
      End With
    End With
End Sub

Public Sub UnicodedialogDez()
Dim strRet        As String
Dim astrText()    As String
Dim i             As Long
   On Error Resume Next
   strRet = InputBox( _
      "Geben Sie die Buchstaben als Zahlencode ein," & _
      vbCrLf & _
      "einzelne Buchstaben bitte durch Komma (,) trennen")
   astrText = Split(strRet, ",")
   strRet = ""
   For i = 0 To UBound(astrText)
      strRet = strRet & ChrW(CLng(astrText(i)))
   Next
   Application.EnableEvents = False
   With ActiveCell
      Select Case MessageBox(0, StrPtr( _
         "Wollen Sie die folgenden Zeichen an den Text anfügen (Ja)," _
         & vbCrLf & _
         "oder wollen Sie den Zellinhalt ersetzen (Nein)?" _
         & vbCrLf & vbCrLf _
         & strRet), _
         StrPtr("Unicodezeichen"), _
         vbYesNoCancel)
         
         Case vbYes
            .Value = .Value & strRet
            .Font.Name = "Arial Unicode MS"
         Case vbNo
            .Value = strRet
            .Font.Name = "Arial Unicode MS"
         Case Else
      End Select
   End With
   Application.EnableEvents = True
End Sub

Public Sub UnicodedialogHez()
Dim strRet        As String
Dim astrText()    As String
Dim i             As Long
   On Error Resume Next
   strRet = InputBox( _
      "Geben Sie die Buchstaben als Hexcode ein," & _
      vbCrLf & _
      "einzelne Buchstaben bitte durch Komma (,) trennen")
   astrText = Split(strRet, ",")
   strRet = ""
   For i = 0 To UBound(astrText)
      strRet = strRet & ChrW("&H" & astrText(i))
   Next
   Application.EnableEvents = False
   With ActiveCell
      Select Case MessageBox(0, StrPtr( _
         "Wollen Sie die folgenden Zeichen an den Text anfügen (Ja)," _
         & vbCrLf & _
         "oder wollen Sie den Zellinhalt ersetzen (Nein)?" _
         & vbCrLf & vbCrLf _
         & strRet), _
         StrPtr("Unicodezeichen"), _
         vbYesNoCancel)
         
         Case vbYes
            .Value = .Value & strRet
            .Font.Name = "Arial Unicode MS"
         Case vbNo
            .Value = strRet
            .Font.Name = "Arial Unicode MS"
         Case Else
      End Select
   End With
   Application.EnableEvents = True
End Sub