Optimale Breite von verbundenen Zellen

07/09/2010 - 12:22 von HelmutMit | Report spam
Hallo,
weiß jemand einen Trick, wie man die Breite verbundener Zellen
automatisch an den Inhalt anpassen kann (gerne auch VBA).
Danke!
Gruß Helmut
 

Lesen sie die antworten

#1 Andreas Killer
07/09/2010 - 17:30 | Warnen spam
Am 07.09.2010 12:22, schrieb HelmutMit:

weiß jemand einen Trick, wie man die Breite verbundener Zellen
automatisch an den Inhalt anpassen kann (gerne auch VBA).


Das ist gar nicht soo einfach wie es im ersten Moment aussieht.

Ich hab da was, allerdings funktioniert das nur mit einem verbundenen Bereich, d.h. hast Du mehrere verbundene Zellen
untereinander wird das nix.

Dafür wird aber sichergestellt das die Spalten/Zeilen eine gleichmàßig verteilte Breite/Höhe bekommen und keine
benachbarte Einzelzelle so klein wird, das Ihr Inhalt nicht mehr komplett sichtbar ist.

Wie man das mit mehreren sich überschneidenden Bereichen anstellen kann... da hab ich keine richtig schicke Idee dazu...
vielleicht müsste man einen umfassenden Breiche übergeben und alle in ihm enthaltenen verbundenen Zellen suchen und
verarbeiten... oder ist das doch ganz einfach und ich stell mich nur dumm an?

In meinem Test habe ich die Zellen D4 bis F6 verbunden.

Andreas.

Sub Test()
AutoFitMergedCells Range("D4")
End Sub

Sub AutoFitMergedCells(ByVal MergedCells As Range)
'Passt eine verbundene Zelle in der Höhe/Breite an den Inhalt an.
Dim SaveScreenUpdating As Boolean, SaveEnableEvents As Boolean
Dim R As Range
Dim MArea As Range, MCell As Range
Dim MRow As Range, MCol As Range
Dim Contents As String
Dim MaxWidth As Single, MaxHeight As Single
Dim MinWidth() As Single, MinHeight() As Single
Dim DestWidth As Single, DestHeight As Single
Dim OverWidth As Single, OverHeight As Single
Dim I As Long

'Wenn keine verbundenen Zellen dann raus
If Not MergedCells.MergeCells Then Exit Sub

'Lieber nicht zeigen was wir alles so machen ;-)
SaveScreenUpdating = Application.ScreenUpdating
SaveEnableEvents = Application.EnableEvents
Application.ScreenUpdating = False
Application.EnableEvents = False

'Sicherstellen das wir alle Zellen haben
Set MArea = MergedCells(1, 1).MergeArea
'Wichtige Bereiche
Set MCell = MArea(1, 1)
Set MRow = MArea.Rows(1).Cells
Set MCol = MArea.Columns(1).Cells

'Zellen trennen
MArea.UnMerge
'Inhalt speichern
Contents = MCell.Formula

'Zelle vergrößern...
MCell.ColumnWidth = 200
MCell.RowHeight = 400
'...und schrumpfen
MCell.EntireRow.AutoFit
MCell.EntireColumn.AutoFit
'Zielgrößen speichern
MaxWidth = MCell.ColumnWidth
MaxHeight = MCell.RowHeight

'Punkte eintragen, Autofit geht mit leeren Zellen nicht!
MArea = "."
'Zellen vergrößern...
For Each R In MRow
R.ColumnWidth = 200
Next
For Each R In MCol
R.RowHeight = 400
Next
'...und schrumpfen
MArea.EntireRow.AutoFit
MArea.EntireColumn.AutoFit

'Min. Größen speichern
ReDim MinWidth(1 To MRow.Count) As Single
I = 0
For Each R In MRow
I = I + 1
MinWidth(I) = R.ColumnWidth
Next
ReDim MinHeight(1 To MCol.Count) As Single
I = 0
For Each R In MCol
I = I + 1
MinHeight(I) = R.RowHeight
Next

'Inhalt wieder herstellen
MArea.ClearContents
MCell.Formula = Contents

'Die ideale Verteilung berechnen
DestWidth = MaxWidth / MRow.Count
DestHeight = MaxHeight / MCol.Count

'Verteilung der Breite prüfen
For I = 1 To UBound(MinWidth)
If MinWidth(I) > DestWidth Then _
OverWidth = OverWidth + MinWidth(I) - DestWidth
Next
'Verteilung der Breite anpassen
For I = 1 To UBound(MinWidth)
If MinWidth(I) <= DestWidth Then
If OverWidth > 0 Then
OverWidth = OverWidth + MinWidth(I) - DestWidth
If OverWidth < 0 Then
MinWidth(I) = MinWidth(I) - OverWidth
OverWidth = 0
End If
Else
MinWidth(I) = DestWidth
End If
End If
Next

'Verteilung der Höhe prüfen
For I = 1 To UBound(MinHeight)
If MinHeight(I) > DestHeight Then _
OverHeight = OverHeight + MinHeight(I) - DestHeight
Next
'Verteilung der Höhe anpassen
For I = 1 To UBound(MinHeight)
If MinHeight(I) <= DestHeight Then
If OverHeight > 0 Then
OverHeight = OverHeight + MinHeight(I) - DestHeight
If OverHeight < 0 Then
MinHeight(I) = MinHeight(I) - OverHeight
OverHeight = 0
End If
Else
MinHeight(I) = DestHeight
End If
End If
Next

'Zellen einstellen
I = 0
For Each R In MRow
I = I + 1
R.ColumnWidth = MinWidth(I)
Next
I = 0
For Each R In MCol
I = I + 1
R.RowHeight = MinHeight(I)
Next

'Zellen wieder verbinden
MArea.Merge

'Nu darfst Du kucken ;-)
Application.ScreenUpdating = SaveScreenUpdating
Application.EnableEvents = SaveEnableEvents
End Sub

Ähnliche fragen