Thema: VBA LeereZeilenZählen

Hallo liebe Community,

ich habe eine kleines Problem mit einem VBA-Makro, welches ich hier im Forum gefunden habe.

Das Makro gibt die Anzahl der Leeren Zeilen innerhalb einer Spalte wieder.

Dabei können mehrere Werte in der Spalte stehen. Das Makro berechnet immer die Anzahl der Leeren Spalten zwischen den einzelnen Etappen.

Jetzt zu meinem Problem. Die Ausgabe des Werte erfolgt immer in der letzten Zeile. Ich möchte die Ausgabe, jedoch immer neben dem Startwert der jeweiligen Etappe haben.

Ich hab schon viel rumprobiert und Zahlen geändert, leider ergebnislos.

Anbei mal der Code, eine Bsp. Datei lade ich auch mal hoch.

https://www.herber.de/bbs/user/176015.xlsm

Vielen Dank schon einmal vorab.

Sub LeereZeilenZählen()

Dim LetzteZeile As Long, LetzteZeileBlock As Long

Dim iZeile As Long

LetzteZeile = Range("A1048576").End(xlUp).Row

Do Until iZeile >= LetzteZeile
iZeile = iZeile + 1

If Cells(iZeile, 1) = "" Then
LetzteZeileBlock = Cells(iZeile, 1).End(xlDown).Row
Cells(LetzteZeileBlock - 1, 2) = LetzteZeileBlock - iZeile
iZeile = LetzteZeileBlock
End If
Loop

End Sub

HI
ich würde das so machen:

Sub LeereZeilenZählen()



Dim rng1 As Range

Dim rng2 As Range



Set rng1 = Cells(1, 1)

Do

    if rng1.Value.Offset(1, 0).value = "" then

        Set rng2 = rng1.End(xlDown)

    else

        Set rng2 = rng1.Offset(1, 0)

    end if

        

    If rng2.Row = Rows.Count Then Exit Do

    

    rng1.Offset(0, 1) = rng2.Row - rng1.Row - 1

    Set rng1 = rng2

Loop



End Sub

das erste IF sorgt für korrekten Lauf, falls zwei Etappen mal direkt aufeinander folgen, ohne Leerzeilen dazwischen.
Gruß Daniel

Hallo Oliver,

Sub LZz()

  Dim rngLZBlock As Range

  For Each rngLZBlock In Columns(1).SpecialCells(xlCellTypeBlanks).Areas

    rngLZBlock.Cells(1).Offset(-1, 1).Value = rngLZBlock.Rows.Count

  Next rngLZBlock

End Sub

Gruß, Uwe

Hallo Uwe,

ich finde diese Variante sehr elegant, weil ich dadurch die nicht ausgefüllten Zeilen in der Auswertungsspalte weiter nutzen kann. Vielen Dank, nochmal!

Gibt es für das Makro eine Möglichkeit, welche mir erlaubt es immer wieder zu aktualisieren, wenn ich das Blatt neu berechne?

LG

Hallo Oliver,

folgender Code kommt in das schon vorhandene VBA-Modul des entsprechenden Tabellenblattes:

Private Sub Worksheet_Calculate()

  Dim lngCalculation As Long

  Dim rngLZBlock As Range

  With Range(Cells(14, 1), Cells(Rows.Count, 1).End(xlUp))

    If Application.CountBlank(.Cells) Then

      On Error Resume Next

      lngCalculation = Application.Calculation

      Application.Calculation = xlCalculationManual

      For Each rngLZBlock In .SpecialCells(xlCellTypeBlanks).Areas

        With rngLZBlock

          .Cells(1).Offset(-1, 1).Value = .Rows.Count

        End With

      Next rngLZBlock

      Application.Calculation = lngCalculation

    On Error GoTo 0

    End If

  End With

End Sub

Gruß, Uwe

Leider funktioniert die VBA nicht in der Tabelle für das es vorgesehen ist.

Ich bekomme immer einen Laufzeitfehler '1004'

Was kann ich tun um dem Abhilfe zu schaffen?

https://www.herber.de/bbs/user/176020.xlsm

LG

Siehe https://www.herber.de/forum/messages/2007447.html

Geht auch ohne VBA.
In A1 kopieren und beliebig weit runterkopieren:

=LET(rn;$A$1:$A1;rng;WENN(rn<>"";ZEILE(rn);"");fi;FILTER(rng;rng<>"");kg;KGRÖSSTE(MTRANS(fi);1);kgg;KGRÖSSTE(MTRANS(fi);2);we;WENN(ISTFEHLER(kgg);kg;kg-kgg);WENN($A1="";"";we))

Hi
noch ne Formellösung:

diese formel in B1 und dann soweit runterziehen wie benlötigt:

=WENN(ODER(A35="";A35="Schluss");"";VERGLEICH("*";A36:A$99999;0)-1)

Gruß Daniel

Moin

Sub LZz_2()



  Dim rngLZBlock As Range, Bereich As Range

  

  Set Bereich = Range(Cells(14, 1), Cells(Rows.Count, 1).End(xlUp).Offset(-1))

  Bereich.Offset(, 1).ClearContents 'alte Zahlen in Spalte B entfernen

  If WorksheetFunction.CountBlank(Bereich) = 0 Then Exit Sub

  For Each rngLZBlock In Bereich.SpecialCells(xlCellTypeBlanks).Areas

     rngLZBlock.Cells(0, 2) = rngLZBlock.Rows.Count 'Anzahl in Spalte B eintragen

  Next rngLZBlock



End Sub

Gruß Gerd

Die MTRANS können übrigens beide (samt Klammern) weg - Restmüll aus der Testphase....