Rahmen um einen Bereich wenn Monat=

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

hi
Muss ins Modul der betreffenden Tabelle d.h. Alt+F11, links Doppelklick auf Tabelle, Code einfügen

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "P2" Then
With Range("C1:N8")
.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
With Range("C2:N7")
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With
With Range(Cells(1, Month(Range("P2")) + 2), Cells(8, Month(Range("P2")) + 2))
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Color = -16776961
.TintAndShade = 0
.Weight = xlThick
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Color = -16776961
.TintAndShade = 0
.Weight = xlThick
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Color = -16776961
.TintAndShade = 0
.Weight = xlThick
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Color = -16776961
.TintAndShade = 0
.Weight = xlThick
End With
End With
End If
End Sub

cu
Chris

Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long If Target.Address = "$P$2" Then '--- Aussenbereich Rahmen löschen For i = 7 To 12 Range("c1:N1,c8:n8").Borders(i).LineStyle = xlNone Next '--- Innenbereich Rahmen neu ziehen For i = 7 To 12 With Range("c2:n7").Borders(i) .LineStyle = xlContinuous .Weight = xlThin .Color = vbBlack End With Next '--- Wenn Datum in Liste, dann Spalte mit Datum rot umranden If WorksheetFunction.CountIf(Range("C2:N2"), Range("P2").Value) = 1 Then For i = 7 To 10 With Range("C1:N8").Columns(WorksheetFunction.Match(Range("P2"), Range("C2:N2"), 0)) _ .Borders(i) .LineStyle = xlContinuous .Weight = xlThick .Color = vbRed End With Next End If End If End Sub

Hallo Chris, hallo Daniel,
lieben Dank für eure schnelle Lösungen!
Sind die beiden Lösungen in der Logik identisch, nur in der Code-Länge unterschiedlich?
@Daniel:
Die bedingte Formatierung funktioniert super, nur bei meiner Tabelle hebt sich der Rahmen schlecht ab.
https://www.herber.de/bbs/user/108748.xlsx
Außerdem sieht man durch die Gruppierung den linken Rand in Spalte F nicht.
Gibt es evtl. die Möglichkeit, nur die Dicke des Rahmens mit VBA zu lösen?
Danke übrigens für die Kommentierungen in deinem VBA-Code! Dürfte ich erfahren was i=7 to 12 und i=7 to 10 aussagen?
@Chris & Daniel:
Bei eurer VBA-Lösung wird die Tabelle neu mit dünnen schwarzen Linien gezeichnet.
Beispiel mit Daniels Code: https://www.herber.de/bbs/user/108749.xlsm
Gibt es die Option, meine Tabellenformatierung zu belassen?
Ist es eigentlich möglich, den VBA-Code größtenteils selbst mit Recorder aufzunehmen und nur die if then Bedingung später im Editor zu ergänzen?
Danke euch für die Unterstützung!
Gruß
Kisska

Private Sub Worksheet_Change(ByVal Target As Range) Dim ÜB As Range Set ÜB = Range("C2:N2") Dim Zelle As Range If Target.Address = "$P$2" Then With Me.Shapes("Rechteck 1") If WorksheetFunction.CountIf(ÜB, Target) > 0 Then Set Zelle = ÜB.Cells(1, WorksheetFunction.Match(Target, ÜB, 0)) .Top = Zelle.Offset(-1, 0).Top .Left = Zelle.Left .Width = Zelle.Width .Height = Range("B3").End(xlDown).Offset(2, 0).Top .Visible = True Else .Visible = False End If End With End If End Sub

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) ' Check this address for changes Const targetAddress As String = "$P$2" ' search target-value in this row to determine... Const matchRow As Long = 2 '... match with column Dim matchedCol As Long ' name of shape to mark range Const matchedMarkName As String = "Rechteck 1" ' Shape object Dim matchedMark As Shape ' Offset of rows from matched cell to top Const matchOffsetTop As Long = -1 ' Offset of rows from matched cell to bottom Const matchOffsetBottom As Long = 6 If Target.Address = "$P$2" Then On Error Resume Next Set matchedMark = Shapes(matchedMarkName) If matchedMark Is Nothing Then MsgBox "No corresponding shape for range marking found!", _ vbCritical, "Marking ranges" On Error GoTo 0 Exit Sub End If matchedMark.Visible = msoFalse matchedCol = Application.Match(Target, Rows(matchRow), 0) On Error GoTo 0 If matchedCol > 0 And matchedCol

Beliebteste Forumthreads (12 Monate)

Rahmen um einen Bereich wenn Monat=

20 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread