Diagonale in Zelle in Abhängigkeit

Sub test1() With Range("A10:A150").SpecialCells(xlCellTypeBlanks).Borders(xlDiagonalDown) .LineStyle = xlDot .Weight = xlThin ' .Color = RGB(0, 0, 0) .ColorIndex = xlAutomatic End With End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
hoffe habe dich richtig verstanden?!
Kannst mal so versuchen/testen.

Sub Test1()
Dim nCol&
Dim rng As Range
Dim objLinie As Shape
Dim oTabelle As Worksheet
'Tabelle anpassen 
Set oTabelle = Tabelle1

On Error GoTo ErrorHandler:
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    
    With oTabelle
        Kill_Linie oTabelle
        nCol = .Cells(5, .Columns.Count).End(xlToLeft).Column
        For nCol = 1 To nCol
            If .Cells(5, nCol) <> "" Then
                Set rng = FindLeerZelle(.Range(.Cells(5, nCol), .Cells(150, nCol)))
                If Not rng Is Nothing Then
                    For Each rng In rng.Areas
                        With rng
                            Set objLinie = oTabelle.Shapes.AddLine(.Left + .Width / 2, _
                                                           .Top, _
                                                           .Left + .Width / 2, _
                                                           .Cells(.Rows.Count, 1).Top + .Cells(.Rows.Count, 1).Height)
                        End With
                        
                        'sonstige Formatierung 
                        With objLinie.Line
                            .Weight = 2
                            .ForeColor.RGB = RGB(164, 166, 164)
                        End With
                    Next rng
                End If
            End If
        Next nCol
    End With

ErrorHandler:
    .ScreenUpdating = True
    .EnableEvents = True
End With

If Err.Number <> 0 Then
    MsgBox Err.Description, _
       vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
       "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
End Sub

Private Function FindLeerZelle(rngBereich As Range) As Range
On Error Resume Next
Set FindLeerZelle = rngBereich.SpecialCells(xlCellTypeBlanks)
End Function

Private Sub Kill_Linie(objTabelle As Object)
Dim oShape As Shape
For Each oShape In Tabelle1.Shapes
    If oShape.Type = msoLine Then oShape.Delete
Next oShape
End Sub

Gruß Tino

Sub test1() If Range("ZELLE 5").Value 1 Then With Range("ZELLE 10:ZELLE 150").SpecialCells(xlCellTypeBlanks).Borders(xlDiagonalDown) .LineStyle = xlDot .Weight = xlThin .ColorIndex = xlAutomatic End With End If End Sub

Sub test1() Dim xCol As Range For Each xCol In UsedRange.Columns If xCol(5).Value 1 Then With xCol.SpecialCells(xlCellTypeBlanks).Borders(xlDiagonalDown) .LineStyle = xlDot .Weight = xlThin .ColorIndex = xlAutomatic End With End If Next xCol End Sub

Beliebteste Forumthreads (12 Monate)

Diagonale in Zelle in Abhängigkeit

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Diagonale in Zelle in Abhängigkeit

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread