Readdy Write  
0,00 €
Your View Money
Views: Count
Self 20% 0
Your Content 60% 0

Users by Links 0
u1*(Content+Views) 10% 0
Follow-Follower 0
s2*(Income) 5% 0

Count
Followers 0
Login Register as User

Excel: Spaltenbreiten und Zeilenhöhen in Excel per vba automatisch anpassen

12.02.2019 (👁10229)

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 >---------