AW: Benutzerdefinierte Formatierung Zahl und Text
25.05.2012 23:20:35
fcs
Hallo Mexsalem,
Leerzeichen haben in der von Mirosoft für die Gültigkeitsauswahl im DropDown verwendete Schriftart eine andere Breite als Ziffern.
Das kriegt man auch dann nicht ausgeglichen, wenn man unterschiedliche Anzahl Leerzeichen vor den Ziffern einfügt.
Du solltes ein Füllzeichen verwenden, das die gleiche Breite wie die Ziffern hat - z.B. "_" - oder "0" als Füllzeichen verwenden. So hast du auch mehr Auswahl bei den Schriften, die du für die Zellen benutzen kannst.
Nachfolgend ein Code, der bei der Eingabe in Zellen automatisch Füllzeichen einfügt.
Gruß
Franz
'Erstellt unter Excel 2010
'Code im Tabellenmodul in dem die Eingaben gemacht werden.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Zelle As Range, Bereich As Range, intPos As Integer, strText As String
Const strFuell = "_" ' Füllzeichen vor den Ziffern
Const AnzZiff = 7 ' max. Anzahl Ziffern vor dem Text
'Eingaben in Spalte A (1) überwachen und ggf. vor Ziffern Füllzeichen einfügen
Set Bereich = Intersect(Target, Columns(1))
If Bereich Is Nothing Then
Else
Application.EnableEvents = False
For Each Zelle In Bereich.Cells
If Zelle.Row > 1 And Not IsEmpty(Zelle) Then
strText = Zelle.Text
'führende Füllzeichen löschen
Do Until Left(strText, 1) strFuell
strText = Mid(strText, 2)
Loop
'Position der letzten Ziffer finden
For intPos = 1 To Len(strText)
Select Case Asc(Mid(strText, intPos, 1))
Case Asc(0) To Asc(9)
If intPos = Len(strText) Then
Zelle.Value = String(AnzZiff - intPos, strFuell)
Exit For
End If
Case Else
If intPos = 1 Then
Zelle.Value = String(AnzZiff, strFuell) & " " & strText
ElseIf intPos = AnzZiff + 1 Then
If Mid(strText, intPos, 1) = " " Then
'do nothing
Else
Zelle.Value = Left(strText, AnzZiff) & " " & Mid(strText, AnzZiff + 1)
End If
Else
Zelle.Value = String(AnzZiff - intPos + 1, strFuell) & Left(strText, intPos - _
1) _
& IIf(Mid(strText, intPos, 1) = " ", "", " ") & Mid(strText, intPos)
End If
Exit For
End Select
Next
End If
Next
Application.EnableEvents = True
End If
End Sub