VBA - USER DEFINED FUNCTIONS

OBJEKTE:   ZELL-RAHMEN

Option Explicit

Sub RahmenLöschen()
Range("C7").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub

Sub RahmenLöschen_WITH()
Range("C7").Select
With Selection
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
End With
End Sub


Sub AlleRahmenEliminieren()
Dim Berechn_Modus, Aktual_Modus, i
Dim Bereich As Range, Areal As Range
Dim x As Integer
x = xlLineStyleNone
If Selection Is Nothing Then Exit Sub
' Geschwindigkeitsoptimierung durch Ausschalten der autom. Re-Kalkulation
Berechn_Modus = Application.Calculation
Aktual_Modus = Application.ScreenUpdating
Application.Calculation = xlManual
Application.ScreenUpdating = False
For Each Areal In Selection.Areas 'für jeden separaten Zellbereich
    For Each Bereich In Areal 'für jede Zelle
    ' alle Rahmen der aktuellen Zelle löschen
     For Each i In Array(xlEdgeTop, xlEdgeBottom, xlEdgeLeft, xlEdgeRight, xlDiagonalDown, xlDiagonalUp)
        Bereich.Borders(i).LineStyle = x
    Next i
    ' rechten Rahmen der links angrenzenden Zelle löschen
    If Bereich.Column > 1 Then
        Bereich.Offset(0, -1).Borders(xlRight).LineStyle = x
    End If
    ' linken Rahmen der rechts angrenzenden Zelle löschen
    If Bereich.Column < MaxSpalten Then
        Bereich.Offset(0, 1).Borders(xlLeft).LineStyle = x
    End If
    ' unteren Rahmen der Zelle oberhalb löschen
    If Bereich.Row > 1 Then
        Bereich.Offset(-1, 0).Borders(xlBottom).LineStyle = x
    End If
     ' oberen Rahmen der Zelle unterhalb löschen
    If Bereich.Row < MaxZeilen Then
        Bereich.Offset(1, 0).Borders(xlTop).LineStyle = x
    End If
Next Bereich
Next Areal
' Ende der Geschwindigkeitsoptimierung
Application.Calculation = Berechn_Modus
Application.ScreenUpdating = Aktual_Modus
End Sub