Tabelle formatieren Rahmen

25/09/2013 - 00:03 von Peter Schuerer | Report spam
Hallo Zusammen (Claus ;-)),

per Makro (aufgezeichnet) formatiere ich eine Tabelle mit Rahmen:

Sub DBProd_sortieren()
'
' DBProd_sortieren Makro
' Datenbank Produktion wird nach Datum sortiert
' und Rahmen gesetzt
'
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("A3"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
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 = xlThin
.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(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

Funktioniert auch und ist sogar (trotz Select) schnell.
In Spalte A steht das Datum im Format "TT.MM.JJJJ" und ich möchte
zwischen den unterschiedlichen Tagen einen Rahmen "xlMedium".
Aber ich bekomme es nicht hin.
Bitte um Hilfe und Lösungsvorschlag.

Danke und Gruß
Peter
 

Lesen sie die antworten

#1 Claus Busch
26/09/2013 - 14:52 | Warnen spam
Hallo Peter,

Am Wed, 25 Sep 2013 00:03:32 +0200 schrieb Peter Schuerer:

Funktioniert auch und ist sogar (trotz Select) schnell.
In Spalte A steht das Datum im Format "TT.MM.JJJJ" und ich möchte
zwischen den unterschiedlichen Tagen einen Rahmen "xlMedium".



wenn ich dich richtig verstanden habe, dann probiers mal so:

Sub Test()
Dim LRow As Long
Dim LCol As Integer
Dim rngC As Range

Application.ScreenUpdating = False
LRow = Cells(Rows.Count, 1).End(xlUp).Row
LCol = Cells(2, Columns.Count).End(xlToLeft).Column
With Range(Cells(2, 1), Cells(LRow, LCol))
.Sort Key1:=Range("A3"), Order1:=xlAscending, _
Header:=xlGuess

With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With

For Each rngC In Range("A3:A" & LRow)
If rngC <> rngC.Offset(1, 0) Then
With Range(Cells(rngC.Row, 1), Cells(rngC.Row, _
LCol)).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.Weight = xlMedium
End With
End If
Next
Application.ScreenUpdating = True
End Sub

Falls das nicht das Gewünschte ist, melde dich nochmals


Mit freundlichen Grüßen
Claus
Win XP Prof SP3 / Vista Ultimate SP2
Office 2003 SP3 /2007 Ultimate SP3

Ähnliche fragen