PDA

Vollständige Version anzeigen : Formatieren Spaltenlinien ab Zeile


thomme1
29.06.2014, 19:04
Geschätzte Forumsgemeinde

Ich hätte da noch einen Code den ich nicht weiss wie ich in für meine Bedürfnisse anpassen muss.
Sub ZeilenFärben()
Application.ScreenUpdating = False
'Variablen dimensionieren
Dim Zeile, ZeilenNr As Integer
'Schleife für die gesamte Selektion
For Zeile = 7 To ActiveSheet.UsedRange.Rows.Count
'Zeilen zählen
ZeilenNr = ZeilenNr + 1
'Für jede 2. Zeile Format festlegen
If ZeilenNr Mod 2 = 0 Then
'Rows(Zeile).Interior.ColorIndex = 3
Rows(Zeile).Interior.Pattern = xlGray16
Rows(Zeile).Interior.PatternColorIndex = 41
Rows(Zeile).Borders.Weight = xlThin
Rows(Zeile).Borders.ColorIndex = 3
Else
Rows(Zeile).Interior.ColorIndex = xlNone
Rows(Zeile).Borders.ColorIndex = xlNone
End If
Next
Application.ScreenUpdating = True
End Sub

Ab Zeile 5 soll er mir für alle Spalten vertikale Linien ziehen und nicht wie oben im Code nur für jede zweite Zeile.

Oder gibt es einen Code wo ab Zeile 7 jede zweite Zeile ein Raster hat und ab Zeile 5 jede Spalte mit durchgehenden Linien versehen werden?

Beste Dank für Eure Hilfen.

Mc Santa
29.06.2014, 20:37
Hallo,

der Code funktioniert bei mir nicht, er läuft zwar ohne Fehler durch, aber ohne sichtbare Anpassungen im Tabellenblatt.
Außerdem sind mir deine Beschreibungen nicht ganz klar.

Trotzdem denke ich, dass ich dir helfen kann :)
Bitte erstelle eine Tabelle, mit Beispieldaten. Ein Tabellenblatt, wie es vorher aussieht. Und ein extra Tabellenblatt wie es nach dem Makro aussehen soll.
Lade diese Datei dann hier im Forum hoch, und ich schreibe dir den Code dazu :)

VG

thomme1
29.06.2014, 20:54
Hallo MC Santa

Anscheinend bist Du an beiden Problemen von mir dran.
Ich habe aber auch hier eine Beispieldatei zum probieren.
Die Zip-Datei ist das Ergebnis wobei hier die Linien als Beispiel schwarz sind, sollten dann aber natürlich dieselbe Farbe haben wie die Zeilenlinien.

Mc Santa
30.06.2014, 09:32
Hallo,

ehrlich gesagt bin ich trotz der Vorlage nicht ganz sicher, wie die Tabelle aussehen soll.

Im Code oben formatierst du im gewählten Bereich immer die gesamte Zeile. In deiner Datei gibt es jedoch innerhalb einer Zeile unterschiedliche Formatierungen. Ich habe nun einen Code erstellt, wie ich denke, was du gemeint hast.

Hilft dir das weiter?

Option Explicit

Sub Makro1()
Dim lastRow As Long, firstRow, L As Long
firstRow = 7
lastRow = Cells(Rows.Count, 16).End(xlUp).Row 'letzte Zeile in Spalte P

Dim bereich As Range
Set bereich = Range(Cells(firstRow, 1), Cells(lastRow, 1)).EntireRow

With bereich
With .Borders
.LineStyle = xlContinuous
.ColorIndex = 15
.TintAndShade = 0
.Weight = xlThin
End With
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End With


Set bereich = Cells(firstRow + 1, 1).EntireRow
For L = firstRow + 3 To lastRow Step 2
Set bereich = Union(bereich, Cells(L, 1).EntireRow)
Next L

With bereich
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders
.LineStyle = xlContinuous
.ColorIndex = 3
.TintAndShade = 0
.Weight = xlThin
End With
With .Interior
.Pattern = xlGray16
.PatternColorIndex = 41
.ColorIndex = xlAutomatic
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End With
End Sub

VG

thomme1
30.06.2014, 11:59
Besten Dank

War schon spät gestern Abend, habe anscheinend die mimr zur Verfügung stehende Tabelle genommen anstelle vorher zu prüfen ob die Darstellung auch richtig ist. Entschuldige bitte.

Ich möchte eigentlich ein Rahmen zeichnen von A 7 bis P letzte Zeile.

Da ich ja schon jede zweite Zeile mit Raster fülle brauche ich keine horizontalen Gitternetzlinien.

Jedoch sollte ich an diversen Spalten links oder rechts, manchmal beidseitig ab Zeile 7 bis zur letzten Zeile eine vertikale Linie haben, zB. Spalte B und Spalte H.

Was muss ich da ändern?

thomme1
03.07.2014, 11:17
Hallo liebe Forumsgemeinde
Habe den Code soweit ändern können das er keine Zeilenlinien druckt und mir für eine Spalte zusätzlich einen Rahmen zieht, jedoch mit absoluten Werten.
Sub Makro1()
Application.ScreenUpdating = False
Dim lastRow As Long, firstRow, L As Long
firstRow = 6
lastRow = Cells(Rows.Count, 16).End(xlUp).Row 'letzte Zeile in Spalte 16

Dim bereich As Range
Set bereich = Range(Cells(firstRow, 1), Cells(lastRow, 1)).EntireRow

With bereich
With .Borders
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic '15
.TintAndShade = 0
.Weight = xlThin
End With
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With

Set bereich = Cells(firstRow + 1, 1).EntireRow
For L = firstRow + 3 To lastRow Step 2
Set bereich = Union(bereich, Cells(L, 1).EntireRow)
Next L

With bereich
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
'With .Borders
'.LineStyle = xlNone 'xlContinuous
'.ColorIndex = xlAutomatic '3
'.TintAndShade = 0
'.Weight = xlThin
'End With
With .Interior
.Pattern = xlGray16
.PatternColorIndex = xlAutomatic '41
.ColorIndex = xlAutomatic
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With

Range("b6:b31").Select 'sollten mehrere unterschiedliche Spalten sein, von Zele 6 bis letzte Zeile "Spalte 16"
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Application.ScreenUpdating = True
End Sub

Wie kann ich diesen Code ergänzen das ich mehrere unabhängige Spalten umrahmen kann? Code anpassen bei "Range("b6:b31").Select"

Lieber wäre mir jedoch zB. Rahmen ziehen Spalte K5 bis letzte Zeile Spalte K.
Vielleicht kann mir da jemand helfen.

Mc Santa
03.07.2014, 12:49
Hallo,

ändere den Teil von dir wie folgt:
Set bereich = Union(Range("B:B"), Range("E:E"), Range("P:P")) 'hier die gewünschten Spalten anpassen
Dim rng As Range, rng2 As Range

For Each rng In bereich.Areas

Set rng2 = Intersect(rng, Range("6:" & lastRow))

rng2.Borders(xlDiagonalDown).LineStyle = xlNone
rng2.Borders(xlDiagonalUp).LineStyle = xlNone

With rng2.Borders
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With

rng2.Borders(xlInsideVertical).LineStyle = xlNone
rng2.Borders(xlInsideHorizontal).LineStyle = xlNone
Next

Hilft dir das weiter?
VG

thomme1
03.07.2014, 13:13
Hallo Mc Santa

Es funktioniert.
Hast mir eine Last vom Herzen genommen.
Bedanke mich für Deine Geduld und Deine Freizeit die Du für uns Anfänger aufwendest.
Dank

Oben in meinem Code suche ich nach der letzten befüllten Zelle in Spalte 16 (P).
Wie muss ich den Code anpassen wenn er nach der letzten befüllten Zeile suchen soll?
Mit meinen geänderten Codezeilen dauert das ewig!
firstRow = 6
'lastRow = Cells(Rows.Count, 16).End(xlUp).Row 'letzte Zeile in Spalte 16
lastRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count

thomme1
07.07.2014, 11:51
Hallo

Bin da auf eine Funktion von Christian gestossen. Diese gibt innert kürzester Zeit in einer Textbox die Zeilennummer eines Arbeitsblattes an, in welcher ein Wert in der Zelle steht.

Option Explicit


Sub test()
MsgBox "LastRow: " & LastRow(Sheets("Tabelle1"))
End Sub


Function LastRow(wks As Worksheet) As Long
Dim lngFirst As Long, lngLast As Long, lngTmp As Long

With Application
If .CountA(wks.Cells) = 0 Then Exit Function
If .CountA(wks.Rows(wks.Rows.Count)) Then
LastRow = wks.Rows.Count: Exit Function
End If
lngLast = wks.Rows.Count
Do While lngLast > lngFirst + 1
lngTmp = (lngFirst + lngLast) \ 2
If .CountA(wks.Rows(lngTmp).Resize(lngLast - lngTmp)) Then _
lngFirst = lngTmp Else lngLast = lngTmp
Loop
If .CountA(wks.Rows(lngLast)) Then LastRow = lngLast Else LastRow = lngFirst
End With
End Function

Wie kann ich das in den Code von #6 und #7 einbauen oder kann ich auf das Ergebnis dieser Textbox verweisen?