Hallo,
ich habe nachfolgenden VBA-Code um leere Zellen je Zeile mittels diagonale Linien zu kennzeichen.
Das ganze prüft sich aktuell spaltenweise. Wenn "E6" ... "F6" ... "G6"... Wert enthält, werden alle freien Zellen senkrecht
gekennzeichnet.
Leider stosse ich mit den Spalten an die Grenzen so das ich das ganze jetzt umstellen müsste.
Also wenn "E4"..."E500" Wert enthält sollen alle freien Zellen waagerecht (Bis "BO4" ..."BO500" gekennzeichnet werden.
Nachfolgend mein bisheriger Code.
Sub Linien_Eing()
Dim nCol&, nRow&
Dim rng As Range, rngHeader As Range
Dim oTabelle As Worksheet
Dim LStyle As XlLineStyle
Dim LWeight As Single
Dim LColorIndex As Integer
LStyle = xlDash 'Style
LWeight = xlThin 'Breite
LColorIndex = 0 'Farbe
'Tabelle anpassen
Set oTabelle = Tabelle2
On Error GoTo ErrorHandler:
With Application
.ScreenUpdating = False
.EnableEvents = False
With oTabelle
Kill_Linie oTabelle
nCol = .Cells(5, .Columns.Count).End(xlToLeft).Column
Set rngHeader = FindLeerZelle(.Range("E6", .Cells(5, nCol)), xlCellTypeConstants)
If rngHeader Is Nothing Then Exit Sub
For nRow = 6 To 58
Set rng = FindLeerZelle(.Range(.Cells(nRow, 1), .Cells(nRow, nCol)), xlCellTypeBlanks)
If Not rng Is Nothing Then
Set rng = Intersect(rng, rngHeader.Offset(nRow - 5))
If Not rng Is Nothing Then
With rng.Borders(xlDiagonalDown)
.LineStyle = LStyle
.ColorIndex = LColorIndex
.Weight = LWeight
End With
End If
End If
Next nRow
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
Bedanke mich für jede Hilfe die mich weiterbringt da ich mit meinen Kenntnissen an die Grenzen stosse.
VG
|