ich möchte im gesamten Blatt die erste numerische Zelle finden.
Ich dachte dabei an Find+IsNumeric, komme damit aber nicht weiter. Kann mir jemand helfen?
Danke
Gruß
marcl
Option Explicit
Sub tst()
Dim rngN As Range
On Error Resume Next
Set rngN = Cells.SpecialCells(xlCellTypeConstants, xlNumbers)
On Error GoTo 0
If rngN Is Nothing Then
MsgBox "Keine numerische Zelle gefunden"
Else
MsgBox rngN.Cells(1) & " in Zelle " & rngN.Cells(1).Address(0, 0)
End If
End Sub
Sub tst2()
Dim rngErg As Range
Set rngErg = rng1Num()
If Not rngErg Is Nothing Then MsgBox rngErg.Value & " in Zelle " & rngErg.Address
MsgBox "Zahl: " & dblZahl1()
End Sub
Function rng1Num() As Range
On Error Resume Next
Set rng1Num = Cells.SpecialCells(xlCellTypeConstants, xlNumbers)
On Error GoTo 0
If Not rng1Num Is Nothing Then Set rng1Num = rng1Num.Cells(1)
End Function
Function dblZahl1() As Double
Dim rngN As Range
On Error Resume Next
Set rngN = Cells.SpecialCells(xlCellTypeConstants, xlNumbers)
On Error GoTo 0
If Not rngN Is Nothing Then dblZahl1 = rngN.Cells(1).Value
End Function
(Es muss nicht immer eine numerische Zelle geben - deshalb die Fehlerbehandlung.)
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
Option Explicit
Sub Marcl()
Dim rng As Range, Zelle1 As String, Zelle2 As String
Dim spLinks As Long, spRechts As Long, ZlOben As Long, ZlUnten As Long
With ActiveSheet
'findet die erste Numerische Zelle
For Each rng In .Cells.SpecialCells(xlCellTypeConstants, 1)
Zelle1 = rng.Address
ZlOben = rng.Row
spLinks = rng.Column
spRechts = spLinks
Exit For
Next
Application.ScreenUpdating = False
'geht bis zur letzten numerischen Zelle
For Each rng In .Cells.SpecialCells(xlCellTypeConstants, 1)
rng.Select
Zelle2 = rng.Address
ZlUnten = rng.Row
If rng.Column > spRechts Then spRechts = rng.Column
If rng.Column
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
For Each rng In .Cells.SpecialCells(xlCellTypeConstants, 1)
Zelle1 = rng.Address
ZlOben = rng.Row
spLinks = rng.Column
spRechts = spLinks
Exit For
Next
wird (wg. "Exit For") die erste Zelle des Special-Bereichs ausgewertet.
Belegt werden ZlOben und spLinks mit Zeile und Spalte dieser Zelle.
Aber: Ist sicher, dass diese Zelle die oberste und linkeste Zelle des Bereichs ist?
In
For Each rng In .Cells.SpecialCells(xlCellTypeConstants, 1)
rng.Select
Zelle2 = rng.Address
ZlUnten = rng.Row
If rng.Column > spRechts Then spRechts = rng.Column
If rng.Column
wird ZlUnten immer wieder überschrieben und hat letztlich als Wert die Zeilennummer der
letzten Zelle der Schleife.
Die letzte Zelle der Schleife muss aber nicht die Zelle mit der größten Zeilennr. sein.
Das hängt stark davon ab, in welcher Reihenfolge die Teilbereiche (Areas) und damit die Zellen
in der Schleife abgearbeitet werden.
Hier wäre also auch so eine "If rng.Row ..."-Zeile nötig.
Schau mal in meiner Beispielmappe das "Protokoll" an. Da siehst du, dass die voletzte
Area $D$7:$E$9 bis Zeile 9 geht, die letzte Area $B$4:$B$8 nur bis Zeile 8.
In deiner Schleife hat ZlUnten einmal den Wert 9, der wird am Schluss aber mit 8 überschrieben.
In meinem Code geht die Schleife über die Areas des Bereichs, das sind vermutlich weniger als die Einzelzellen.
Jede Area ist rechteckig, deshalb reicht es hier aus, die erste und die letzte Zelle der Area auszuwerten.
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort