VBA: Optimale Breite eines Bereiches

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub spb() Dim arr, a Dim sp As Long, ze As Long sp = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column + 2 arr = Array("D120:H500", "K120:M500", "Z120:Z500") For Each a In arr With Cells(Range(a).Row, sp) Range(a).Copy .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats With .Resize(, Range(a).Columns.Count).EntireColumn .AutoFit .Copy Cells(1, Range(a).Column).PasteSpecial xlPasteColumnWidths .Delete End With End With Next End Sub

Hallo Walter,
vielleicht gibt es eine intelligente Lösung - ich würde z.B. D120:H500 in ein temporäres Blatt kopieren bzw. mit Tabelle2.xxx.Value = D120:H500.value übernehmen, dort mit autofit die optimale breite feststellen und diese dann zurück übertragen und am Ende das temporäe Blatt löschen.
Bislang kenne ich Autofit nur auf eine ganze Spalte bezogen, und da hilft auch nicht das Ausblenden nicht benötigter Bereiche :-(
Wenn man die Vorgehensweise von Excel beim Autofit nachstellt, könnte man das auch zellbezogen tun :-) Beim Autofit scheint Excel jede einzelne Zelle zu prüfen - man merkt's, wenn die Datenbereiche größer werden :-( Ich hab mal in einem Projekt, wo in einer bestimmten Zelle garantiert immer die größte Breite anzutreffen war, nur diese temporär gefittet (damals allerdings mit einer Textbox) und davon den Wert übernommen.
Eventuell kannst Du aber auch eine Breite vordefinieren, die alle Eventualitäten berücksichtigt. Würde sich vielleicht auch besser machen, als wenn sich die Breite nach Datenänderungen immer wieder ändert.
Aber wie gesagt, vielleicht gibt's eine intelligentere Lösung ...
Grüße, André

Sub Test() Dim rng As Range, rngTmp As Range Dim sFormat$, objTab As Worksheet Set rng = Tabelle1.Range("D120:H500,K120:M500,Z120:Z500") Set objTab = Sheets(rng.Parent.Name) For Each rng In rng.Columns With rng Set rngTmp = objTab.Range(objTab.Cells(1, .Column), .Cells(1, 1).Offset(-1, 0)) Set rngTmp = Union(objTab.Range(.Cells(.Rows.Count, 1).Offset(1, 0), objTab.Cells(objTab.Rows.Count, .Column)), rngTmp) sFormat = .Cells(.Rows.Count, 1).NumberFormat rngTmp.NumberFormat = ";;;" rngTmp.EntireColumn.AutoFit rngTmp.NumberFormat = sFormat End With Next rng

Hallo zusammen,
vielleicht kann man auch beide Lösungen kombinieren...

Sub AutoFitZellen()
'Makro zur Festlegung der optimalen Spaltenbreite anhand eines 
'definierten Bereiches mit Hilfe eines temporaeren Blattes 
'Hinweis: 
'ggf. vorher calculation, events, alerts und screenupdating ruecksetzen! 
'Variablendeklarationen 
'Range 
Dim rng As Range, rngCol As Range, rngTmp As Range
'Worksheet 
Dim objTab As Worksheet
'String-Konstante (Name vom Originalblatt) 
Const strOrig As String = "Tabelle1"
  'Originalblatt ans Ende kopieren 
  Sheets(strOrig).Copy After:=Sheets(Sheets.Count)
  'Tabellenblatt dem Objekt zuweisen 
  Set objTab = Sheets(Sheets.Count)
  'zu bearbeitenden Bereich festlegen 
  Set rng = objTab.Range("D120:H500,K120:M500,Z120:Z500")
  'Schleife ueber jede Spalte im rng 
  For Each rngCol In rng.Columns
    'Mit dem Rng 
    With rngCol
        'Bereich ueber dem rng festlegen - 
        'Optimierungsbedarf: Pruefen, ob da auch was drueber ist 
        Set rngTmp = objTab.Range(objTab.Cells(1, .Column), .Cells(1, 1).Offset(-1, 0))
        'Bereich unter dem rng festlegen - 
        'Optimierungsbedarf: Pruefen, ob da auch was drunter ist 
        Set rngTmp = Union(objTab.Range(.Cells(.Rows.Count, 1).Offset(1, 0), objTab.Cells(objTab.Rows.Count, .Column)), rngTmp)
        'Format "nix anzeigen" setzen 
        rngTmp.NumberFormat = ";;;"
        'Spaltenbreite automatisch optimieren 
        rngTmp.EntireColumn.AutoFit
        'Spaltenbreite auf Originalblatt uebertragen 
        Sheets(strOrig).Columns(.Column).ColumnWidth = objTab.Columns(.Column).ColumnWidth
        'End With 
    'Ende Mit dem Rng 
    End With
  'Ende Schleife ueber jede Spalte im rng 
  Next
  'Blattobjekt zuruecksetzen 
  Set objTab = Nothing
  'Meldungen ausschalten 
  Application.DisplayAlerts = False
  'temporaeres Blatt loeschen 
  Sheets(Sheets.Count).Delete
  'Meldungen einschalten - waren die denn vorher ein? 
  Application.DisplayAlerts = True
End Sub

Hoffe geholfen zu haben

Grüße von André aus G in T (xls 97-2013)

Beliebteste Forumthreads (12 Monate)

VBA: Optimale Breite eines Bereiches

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread