an Stefan - LÖSUNG !!!!
24.02.2004 09:58:20
Alex K.
Hallo Stefan,
hier ein Lösungsvorschlag. Zur Formatierung das Makro "NumCenter" starten und alle Spalten mit einem bestimmten Namen in der Arbeitsmappe werden formatiert.
Das Makro macht nichts anderes, als zu errechnen, wieviel Leerzeichen an das Zahlenformat angehängt werden müssen, damit bei rechtsbündiger Ausrichtung die Zahl einigermassen in der Mitte der Spalte steht. Also ein Format '0,000' wird in '0,000" "' umgewandelt.
Zur Vorbereitung musst du alle Spalten bzw. Zellbereiche, welche zu formatierende Zahlen enthalten, folgendermassen bearbeiten:
1) Vergib ein Zahlenformat, welches die max. Anzahl an Nachkommastellen berücksichtigt. Also z.B. für Zahlen mit drei Nachkommastellen ein "#.##0,000"
2) Vergib für die gesammte Spalte bzw. für einen bestimmten Spaltenbereich einen Namen, welcher mit "NumFormat" beginnen muss. Also z.B. Spalte A bekommt den Namen "NumFormat1", Spaltenbereich B10:B100 bekommt den Namen "NumFormatAuswertung". Wichtig ist hier, dass der Name sich immer nur auf EINE Spalte beziehen darf. Wenn du eine ganze Spalte benennst, wird die Zeile mit der ersten Zahl gesucht und von da ab bis zur letzten Zeile das Zahlenformat vergeben. Wenn du einen Spaltenbereich benennst, so wird nur für diesen Bereich ein Zahlenformat angelegt.
Nachteil an der Lösung ist, dass diese nicht automatisch startet, wenn du die Breite einer Zelle änderst. Leider bekommt man in Excel VBA dieses Ereignis nicht mit :-(
So musst du das Makro bei Änderungen in der Spaltenbreite immer von Hand starten. Ich hoffe, dies ist praktikabel.
Ausserdem funktioniert das Ganze nicht, wenn die Nachkommzellen in verbundenen Zellen stehen. Falls du solche Fälle hast, dann melde dich, ich versuche dann, dies ebenfalls zu lösen.
Bitte den nachfolgenden Code in ein Modul im VBA-Editor kopieren. Hierzu über das Menü "Extras -> Visual Baisc Editor" den VBA Editor starten. Dort im Menü "Einfügen -> Modul" ein neues Modul anlegen. Es geht ein Fenster mit der Beschriftung "... Modul1 (Code)" auf. Dort den nachfolgenden Code einfügen. Dann kannst du in Excel über Menü "Extras -> Makro" und Anwahl von "NumCenter" die Formatierung starten.
Option Explicit
Private Const AKNumFormat = "NumFormat"
Private Const AKFormatChar = " "
Public Sub NumCenter()
Dim numRng As Range
Dim actName As Name
For Each actName In ActiveWorkbook.Names
If Left(actName.Name, Len(AKNumFormat)) = AKNumFormat Or _
InStr(1, actName.Name, "!" & AKNumFormat, vbTextCompare) > 0 Then
NumCenterRange actName.RefersToRange
End If
Next actName
End Sub
Private Sub NumCenterRange(Target As Range)
Dim testCell As Range
Dim numRng As Range
Dim numMax As Double
Dim firstRow As Long
Dim saveWidth As Double
Dim maxWidth As Double
Dim charWidth As Double
On Error Resume Next
With Target.Worksheet
If Target.Address = .Range(.Cells(1, Target.Column), _
.Cells(.Rows.Count, Target.Column)).Address Then
firstRow = .Range(.Cells(1, Target.Column), .Cells(.UsedRange.Rows.Count, _
Target.Column)).SpecialCells(xlCellTypeConstants, xlNumbers).Row
Set numRng = .Range(.Cells(firstRow, Target.Column), .Cells(.UsedRange.Rows.Count, Target.Column))
Else
Set numRng = Target
End If
numMax = WorksheetFunction.Max(Target)
If Err.Number <> 0 Then
Exit Sub
End If
Application.ScreenUpdating = False
Application.StatusBar = "Bitte warten - Formatierung läuft"
Set testCell = .Cells(1, .Columns(.Columns.Count).End(xlToLeft).Column + 1)
saveWidth = testCell.ColumnWidth
testCell.Value = numMax
testCell.Columns.AutoFit
maxWidth = testCell.ColumnWidth
testCell.Value = AKFormatChar
testCell.Columns.AutoFit
charWidth = testCell.ColumnWidth
testCell.ColumnWidth = saveWidth
testCell.Value = ""
saveWidth = CInt((numRng.ColumnWidth - maxWidth) / charWidth)
maxWidth = InStr(1, numRng(1).NumberFormatLocal, """", vbTextCompare) - 1
If maxWidth < 1 Then
maxWidth = Len(numRng(1).NumberFormatLocal) + 1
End If
numRng.NumberFormatLocal = Left(numRng(1).NumberFormatLocal, maxWidth) & """" & String(saveWidth, AKFormatChar) & """"
numRng.HorizontalAlignment = xlHAlignRight
Application.ScreenUpdating = True
Application.StatusBar = ""
End With
End Sub