AW: Korrektur
07.11.2008 08:31:24
Erich
Hi Marcel und Matthias,
der Code funktioniert in diesem Beispiel gut, das ist aber nicht immer so.
Er geht davon aus, dass die letzte in der Schleife erreichte Zelle
auch die unterste bzw. am weitesten rechts liegende ist.
Das ist aber nicht sicher. Ein Beispiel ist in dieser Mappe: https://www.herber.de/bbs/user/56582.xls
B4:B8 geht nicht bis zur letzten Zeile des Bereichs, ist aber die letzte Area.
Enthalten sind darin Matthias' Prozedur, die Zeile 9 nicht mitrahmt,
eine kurze, die nur den Bereich markiert und eine lange mit einer Art Protokoll und dem Rahmen.
In den neuen Prozeduren gibt es eine Schleife über die Teilbereiche (Areas), von denen immer
die erste bzw. letzte Zelle ausgewertet wird. das sollte immer funzen.
Hier die beiden neuen Prozeduren aus der Mappe:
Option Explicit
Sub SpecialCells_Bereich()
Dim rngS As Range, rngN As Range, rng As Range
Dim lngZvon As Long, lngZbis As Long, lngSvon As Long, lngSbis As Long
Set rngS = Range("B:G")
With rngS
lngZvon = .Row + .Rows.Count - 1
lngSvon = .Column + .Columns.Count - 1
Set rngN = .SpecialCells(xlCellTypeConstants, xlNumbers)
End With
For Each rng In rngN.Areas
With rng
lngZvon = Application.Min(lngZvon, .Row)
lngSvon = Application.Min(lngSvon, .Column)
lngZbis = Application.Max(lngZbis, .Cells(.Count).Row)
lngSbis = Application.Max(lngSbis, .Cells(.Count).Column)
End With
Next
With Range(Cells(lngZvon, lngSvon), Cells(lngZbis, lngSbis))
.Select ' oder besser: tue etwas mit dem Bereich, z. B. Rahmen setzen
End With
End Sub
Sub SpecialCells_Bereich_Test()
Dim rngS As Range, rngN As Range, rng As Range, zz As Long
Dim lngZvon As Long, lngZbis As Long, lngSvon As Long, lngSbis As Long
Set rngS = Range("B:G")
With rngS
.Borders.LineStyle = xlNone ' Rahmen löschen
lngZvon = .Row + .Rows.Count - 1
lngSvon = .Column + .Columns.Count - 1
Set rngN = .SpecialCells(xlCellTypeConstants, xlNumbers)
zz = zz + 1
Cells(zz, 9) = .Address
Cells(zz, 10) = .Cells(.Count).Address
Cells(zz, 11) = lngZvon
Cells(zz, 12) = lngSvon
Cells(zz, 13) = lngZbis
Cells(zz, 14) = lngSbis
Cells(zz, 15) = .Cells(1)
End With
For Each rng In rngN.Areas
With rng
lngZvon = Application.Min(lngZvon, .Row)
lngSvon = Application.Min(lngSvon, .Column)
lngZbis = Application.Max(lngZbis, .Cells(.Count).Row)
lngSbis = Application.Max(lngSbis, .Cells(.Count).Column)
zz = zz + 1
Cells(zz, 9) = .Address
Cells(zz, 10) = .Cells(.Count).Address
Cells(zz, 11) = lngZvon
Cells(zz, 12) = lngSvon
Cells(zz, 13) = lngZbis
Cells(zz, 14) = lngSbis
Cells(zz, 15) = .Cells(1)
End With
Next
With Range(Cells(lngZvon, lngSvon), Cells(lngZbis, lngSbis)) ' Rahmen setzen
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
End With
End Sub
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
