Rahmen über VBA

Hallo Leute
Habe unteres Makro mittels Recorder aufgezeichnet.
Habe auch eine Beispielmappe hochgeladen.
Wenn kein Wert, dann kein Rahmen im Rechteck, sonst Rahmen.
Mit Bedingte Formatierung wird die Mappe so aufgebläht.
Denn es geht von B3 bis AX2013
Könnte mir dabei bitte jemand weiterhelfen ?
Danke, Heinz


Sub Rahmen()
' Rahmen Makro
Range("P19:V22").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
Range("T21:U22").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
End Sub

Die Datei https://www.herber.de/bbs/user/36798.xls wurde aus Datenschutzgründen gelöscht

Hallo Heinz,
ich habe ein wenig gebastelt und folgendes Makro ist dabei herausgekommen. Das Makro in ein Modul in der Datei einfügen und starten wenn die Tabelle angezeigt wird.
Das Makro formatiert die gesamte Tabelle korrekt, wenn diese ab Zelle B3 nach rechts/unten immer gleich strukturiert ist wie in dem Beispiel. Dabei wird eine Zwischenzeile für die "Kalenderwoche" erkannt und berücksichtigt.
Gruss
Franz


Sub Rahmen()
Dim wks As Worksheet, ZeileS As Long, SpalteS As Integer, DeltaZ As Integer, DeltaS As Integer
Dim Bereich As Range, Zelle As Range, i As Long, Tage As Long, Zeile As Long
Set wks = ActiveSheet
Application.ScreenUpdating = False
With wks
ZeileS = 3 'Startzeile
SpalteS = 2 'Startspalte (B)
DeltaZ = 5 'Zeilen pro Tag
DeltaS = 7 'Spalten pro Eintrag
MaxEintrag = Application.WorksheetFunction.CountA(.Range("B1:IV1")) 'max. Zahl Einträge pro Tag (311, 312, 321, etc.)
Tage = Application.WorksheetFunction.CountA(.Range(.Cells(3, "A"), .Cells(.Rows.Count, "A").End(xlUp))) / 2 ' Anzahl Tage in Liste
Zeile = ZeileS
For i = 1 To Tage
For spalte = 0 To MaxEintrag - 1
'Zelle links oben im zu formatierenden Eintrag
Set Zelle = .Cells(Zeile, SpalteS + spalte * DeltaS)
'Bereich mit Daten für einen Eintrag
Set Bereich = Zelle.Range("A1:G5")
'Rahmen um Daten des Eintrags als einfache Linie setzen, Eintrag ganz Links/Rechts/Unten mit Doppellinie
If spalte = 0 Then ' 1. Eintrag in Zeile, Spalte Links mit Doppellinie
With Bereich.Borders(xlEdgeLeft)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
Else
With Bereich.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End If
If spalte = MaxEintrag - 1 Then 'Letzer Eintrag in Zeile, Spalte rechts mit Doppellinie
With Bereich.Borders(xlEdgeRight)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
Else
With Bereich.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End If
With Bereich.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
If i = Tage Then 'Letzte Einträge unten mit Doppellinie
With Bereich.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
Else
With Bereich.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End If
'Innenlinien entfernen
Bereich.Borders(xlInsideVertical).LineStyle = xlNone
Bereich.Borders(xlInsideHorizontal).LineStyle = xlNone
'Überprüfen, ob im Bereich des Eintrags Daten vorhanden sind
If Application.WorksheetFunction.CountA(Bereich) <> 0 Then
'Linien im Innenbereich formatieren
'Obere 3 Zeilen mit durchgehenden Haarlinien formatieren
Set Bereich = Zelle.Offset(1, 0).Range("A1:G2")
With Bereich.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Bereich.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Bereich.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
'Zellenblock 2 Zeilen 4 spalten unten Links formatieren
Set Bereich = Zelle.Offset(3, 0).Range("A1:D2")
With Bereich.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Bereich.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
'Zellenblock 2 Zeilen 3 Spalten unten rechts formatieren
Set Bereich = Zelle.Offset(3, 4).Range("A1:C2")
With Bereich.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Bereich.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
End If
Next spalte
Zeile = Zeile + DeltaZ
If .Cells(Zeile, SpalteS).Value = "Kalenderwoche" Then Zeile = Zeile + 1
Next i
End With
Application.ScreenUpdating = True
MsgBox "Formatierung abgeschlossen!"
End Sub
b

Forumthread: Rahmen über VBA

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial

Rahmen mit VBA in Excel erstellen

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)