Autor: Uwe Küstner  --- Aus Excel VBA - Gruppe: Häufige Fragen

Nichtleere Zellen erfassen

Autor: Uwe Küstner - Erstellt: --      - Letzte Revision: --
Häufig steht man vor der Aufgabe, Zellen zu erfassen, die nicht leer sind.

Es gibt zwar dafür die SpecialCells-Methode, aber da muss man sich entscheiden,
ob man Zellen mit Werten oder Zellen mit Formeln will.

Eine direkte Umkehr von .SpecialCells(xlCellTypeBlanks), welche alle leeren Zellen erfasst, gibt es leider nicht.

Mit folgender Funktion ist es jedoch möglich:sm1 (1K)

Option Explicit
Option Private Module
'Diese Funktion ist nur in VBA anwendbar.
'Option Private Module macht diese Funktion
'im Formelassistenten (unter Benutzerdefiniert)
'unsichtbar
 
Public Function NoBlanks(Optional rB As Variant) As Range
 Dim rngWerte As Range
 Dim rngFormeln As Range
 Dim rngNichtLeer As Range
 If IsMissing(rB) Then
 If TypeName(ActiveSheet) = "Worksheet" Then Set rB = ActiveSheet.Cells
 End If
 On Error Resume Next
 If TypeName(rB) <> "Range" Then Exit Function
 'Zellen mit Werten
 Set rngWerte = rB.Parent.Cells.SpecialCells(xlCellTypeConstants)
 'Zellen mit Formeln
 Set rngFormeln = rB.Parent.Cells.SpecialCells(xlCellTypeFormulas)
 If Not rngWerte Is Nothing Then Set rngNichtLeer = rngWerte
 If Not rngFormeln Is Nothing Then
  If rngNichtLeer Is Nothing Then
   Set rngNichtLeer = rngFormeln
  Else
   Set rngNichtLeer = Application.Union(rngNichtLeer, rngFormeln)
  End If
 End If
 If Not rngNichtLeer Is Nothing Then Set NoBlanks = _
 Application.Intersect(rB, rngNichtLeer)
End Function
 
Sub Test_NoBlanks()
 Dim rng As Range
 'Set rng = NoBlanks() 'aktives Blatt alle Zellen
 'Set rng = NoBlanks(Sheets("Tabelle2").Cells) 'angegebenes Blatt alle Zellen
 'Set rng = NoBlanks(Range("B2:F5")) 'aktives Blatt angegebener Bereich
 'angegebenes Blatt angegebener Bereich:
 Set rng = NoBlanks(Sheets("Tabelle2").Range("B2:F5"))
 If Not rng Is Nothing Then
  'Alle Nichtleeren Zellen des Bereiches = roter Hintergrund
  rng.Interior.ColorIndex = 3
 End If
End Sub

Weitere Artikel der Gruppe: Häufige Fragen Aus Excel VBA
Nach oben
ToDo
Google Werbung