sztm-excel/src/macros/SZTM_Zahlliste.bas

Attribute VB_Name = "Module1"
Sub SZTM_Zahlliste()
Attribute SZTM_Zahlliste.VB_Description = "Formatiert die Zahlliste"
Attribute SZTM_Zahlliste.VB_ProcData.VB_Invoke_Func = "F\n14"
'
' SZTM_Zahlliste Macro
' Formatiert die Zahlliste
'
' Keyboard Shortcut: Ctrl+Shift+F
'
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Sheets
        With ws
        
            ws.Activate
            
            'Select first row, change font size, make bold and merge
            Range("A1:F1").Select
            With Selection
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlBottom
                .WrapText = False
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = True
            End With
            Selection.Merge
            With Selection.Font
                .Name = "Calibri"
                .Size = 14
                .Strikethrough = False
                .Superscript = False
                .Subscript = False
                .OutlineFont = False
                .Shadow = False
                .Underline = xlUnderlineStyleNone
                .ThemeColor = xlThemeColorLight1
                .TintAndShade = 0
                .ThemeFont = xlThemeFontMinor
            End With
            Selection.Font.Bold = True
            
            'Select second row, make bold and merge
            Range("A2:F2").Select
            With Selection
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlBottom
                .WrapText = False
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = True
            End With
            Selection.Merge
            Selection.Font.Bold = True
            
            'Select price cells and merge
            Range("C4:F4").Select
            Selection.Merge
            
            'Select last cell
            ActiveCell.SpecialCells(xlLastCell).Select
            Selection.Offset(0, -2).Select
            Selection.Resize(Selection.Rows.Count + 1, Selection.Columns.Count + 2).Select
            Selection.Merge
            
            Selection.Offset(0, -3).Select
            Selection.Resize(Selection.Rows.Count + 1, Selection.Columns.Count + 2).Select
            Selection.Merge
            
            Selection.Offset(-1, 0).Select
            Selection.Font.Bold = True
            Selection.Offset(0, 1).Select
            Selection.Resize(Selection.Rows.Count, Selection.Columns.Count + 1).Select
            Selection.Merge
            Selection.Offset(0, 1).Select
            Selection.Font.Bold = True
            Selection.Offset(0, 1).Select
            Selection.Resize(Selection.Rows.Count, Selection.Columns.Count + 1).Select
            Selection.Merge
            
            Selection.Offset(-1, -4).Select
            Selection.Font.Bold = True
            Selection.Offset(0, 1).Select
            Selection.Resize(Selection.Rows.Count, Selection.Columns.Count + 1).Select
            Selection.Merge
            
            Selection.Offset(0, -1).Select
            Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
            Selection.Resize(Selection.Rows.Count - 1, Selection.Columns.Count).Select
            Selection.Borders(xlDiagonalDown).LineStyle = xlNone
            Selection.Borders(xlDiagonalUp).LineStyle = xlNone
            With Selection.Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With Selection.Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With Selection.Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With Selection.Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With Selection.Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            
                
            'Select all data cells, activate grid, fit width, increase height and add header.
            Range("A6:F6").Select
            With Selection.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = -0.149998474074526
                .PatternTintAndShade = 0
            End With
            Selection.Font.Bold = True
            ActiveWindow.SmallScroll Down:=-3
            Range("A6").Select
            Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
            Selection.Resize(Selection.Rows.Count - 6, Selection.Columns.Count).Select
            Selection.Borders(xlDiagonalDown).LineStyle = xlNone
            Selection.Borders(xlDiagonalUp).LineStyle = xlNone
            With Selection.Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With Selection.Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With Selection.Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With Selection.Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With Selection.Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            Selection.RowHeight = 33.75
            Selection.EntireColumn.AutoFit
            'Columns("A:A").EntireColumn.AutoFit
            'Columns("B:B").EntireColumn.AutoFit
            'Columns("C:C").EntireColumn.AutoFit
            'Columns("D:D").EntireColumn.AutoFit
            'Columns("E:E").EntireColumn.AutoFit
            
        End With
    Next

End Sub