Excel: Spaltenbreiten und Zeilenhöhen in Excel per vba automatisch anpassen
Kleines vba Makro, mit welchem man in einer Excel Datei alle Zeilen und Spalten automatisch anhand einer Zahl in der Zeile 1 oder Spalte 1 in Pixel anpassen kann.
Die Datei liegt als Download mit vba Makro bereit.
Der Code kann in andere Anwendungen eingefügt werden.
Excel Vba Code
Option Explicit '***********< Zeilen und Spalten anpassen >**************** Public Sub Breiten_und_Hoehen_auf_Blatt_anpassen(ByVal sSheetname As String) '-----------------< Breiten_und_Hoehen_auf_Blatt_anpassen() >----------------- '*Blendet Spalten mit z ein aus '*columnwidth in points
'< active Workbook > Dim wb As Workbook Set wb = ActiveWorkbook '</ active Workbook >
Application.ScreenUpdating = False
'----< Sheets ermitteln >---- Dim ws As Worksheet '--< @Loop: alle Sheets >-- Set ws = wb.Worksheets(sSheetname) Dim varValue As Variant Dim setPixel As Double
'-< Columns >- Dim iCol As Integer For iCol = ws.UsedRange.Columns.Count To 1 Step -1 varValue = ws.Cells(1, iCol).Value If IsNumeric(varValue) And Not IsEmpty(varValue) Then Dim col As Range Set col = ws.Columns(iCol)
setPixel = varValue
If setPixel = 0 Then '---< Hide >---- If col.EntireColumn.Hidden <> True Then col.EntireColumn.Hidden = True '---</ Hide >---- Else '---< set Width >---- Dim setColWidth setColWidth = PixelsToColumnWidth(setPixel)
Dim actColWidth As Double actColWidth = col.ColumnWidth If actColWidth <> setColWidth Then Application.StatusBar = Now & " " & sSheetname & ".col " & iCol & " " & actColWidth & "->" & setColWidth DoEvents col.ColumnWidth = setColWidth End If
'---</ set Width >---- End If End If Next '-</ Columns >-
'-< Rows >- '*Rows von Pixel zu dpi umrechnen '< factor > Dim factor_dpi As Double factor_dpi = Application.InchesToPoints(1) '72
Dim factor_pixel As Double factor_pixel = ThisWorkbook.WebOptions.PixelsPerInch '96
Dim factor_pixel_dpi As Double factor_pixel_dpi = factor_pixel / factor_dpi '1,333 80pixel=60dpi '</ factor >
Dim iRow As Integer For iRow = ws.UsedRange.Rows.Count To 1 Step -1 varValue = ws.Cells(iRow, 1).Value If IsNumeric(varValue) And Not IsEmpty(varValue) Then Dim row As Range Set row = ws.Rows(iRow)
setPixel = varValue
If setPixel = 0 Then '---< Hide >---- If col.EntireRow.Hidden <> True Then col.EntireRow.Hidden = True '---</ Hide >---- Else '---< set Height >---- Dim setRowHeight setRowHeight = setPixel / factor_pixel_dpi
Dim actRowHeigth As Double actRowHeigth = row.RowHeight If actRowHeigth <> setRowHeight Then Application.StatusBar = Now & " " & sSheetname & ".row " & iRow & " " & actRowHeigth & "->" & setRowHeight DoEvents row.RowHeight = setRowHeight End If
'---</ set Height >---- End If End If Next '-</ Columns >-
Application.StatusBar = Now & " fertig: Breiten Hoehen angepasst" Application.ScreenUpdating = True '-----------------</ Breiten_und_Hoehen_auf_Blatt_anpassen() >----------------- End Sub
'-------< Helper: Calculations >--------- Function ColumnWidthToPixels(ByVal ColWidth As Single) As Integer Select Case Round(ColWidth, 4) ' Adjust for floating point errors Case Is < 0: ColumnWidthToPixels = ColumnWidthToPixels(ActiveSheet.StandardWidth) Case Is < 1: ColumnWidthToPixels = Round(ColWidth * 12, 0) Case Is <= 255: ColumnWidthToPixels = Round(12 + ((Int(ColWidth) - 1) * 7) _ + Round((ColWidth - Int(ColWidth)) * 7, 0), 0) Case Else: ColumnWidthToPixels = ColumnWidthToPixels(ActiveSheet.StandardWidth) End Select End Function
Function PixelsToColumnWidth(ByVal Pixels As Integer) As Single Select Case Pixels Case Is < 0: PixelsToColumnWidth = ActiveSheet.StandardWidth Case Is < 12: PixelsToColumnWidth = Round(Pixels / 12, 2) Case Is <= 1790: PixelsToColumnWidth = Round(1 + ((Pixels - 12) / 7), 2) Case Else: PixelsToColumnWidth = ActiveSheet.StandardWidth End Select End Function '-------</ Helper: Calculations >--------- |