Excel VBA Zellen einfügen ohne überschreiben

Hallo zusammen,
ich habe ein kleines Problem mit meinem Excel VBA. Da ich mich leider nicht so gut auskenne, finde ich die Lösung nicht.
Ich habe mehrere Tabellenblätter in einer Datei in der immer mal wieder Zellen rot markiert sind. Jetzt habe ich ein Makro geschrieben, dass er mir aus allen Tabellenblättern die Zeile mit den roten Zellen in ein extra Tabellenblatt namens Übersicht kopiert.
Mein Problem dabei ist, dass er dabei die Zellen immer überschreibt. Das heißt er fügt aus dem ersten Tabellenblatt alle roten Zellen ab A1 ein und für das zweite Tabellenblatt fügt er auch alle Zellen ein aber beginnt dabei wieder bei A1. Wo und welchen Befehl kann ich einfügen, damit er mir guckt ob in der Zeile was steht und das er dann die Zeilen drunter einfügt?
Zum besseren Verständnis füge ich euch meinen Code ein:

Function rot_markieren()
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
sh.Activate
Dim rngzelle        As Range
Dim lngZeile        As Long
lngZeile = 1
With Worksheets("Übersicht")   'Hier Name des Zielblattes anpassn
For Each rngzelle In ActiveSheet.Range("A1:HH50")   'Suchbereich anpassen
If rngzelle.Interior.ColorIndex = 3 Then
rngzelle.EntireRow.Copy .Cells(lngZeile, 1)
lngZeile = lngZeile + 1
End If
Next rngzelle
End With
Next
End Function

Ich würde mich freuen, wenn mir jemand helfen könnte.
Viele Grüße

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
da war noch ein kleiner Fehler drin.

Public Sub rot_markieren()

    Const OVERVIEW_SHEET As String = "Übersicht"
    Dim sh As Worksheet
    Dim rngzelle As Range
    Dim lngZeile As Long
    Dim strFirstAddress As String

    With Application.FindFormat
        Call .Clear
        .Interior.ColorIndex = 3
    End With

    For Each sh In ThisWorkbook.Worksheets

        If sh.Name <> OVERVIEW_SHEET Then

            Set rngzelle = sh.Range("A1:HH50").Find(What:=vbNullString, _
                LookAt:=xlPart, SearchFormat:=True)

            If Not rngzelle Is Nothing Then

                strFirstAddress = rngzelle.Address

                Do

                    lngZeile = lngZeile + 1

                    Call rngzelle.EntireRow.Copy(Destination:= _
                        Worksheets(OVERVIEW_SHEET).Cells(lngZeile, 1))

                    Set rngzelle = sh.Range("A1:HH50").Find(What:=vbNullString, _
                        After:=rngzelle, LookAt:=xlPart, SearchFormat:=True)

                Loop Until rngzelle.Address = strFirstAddress

                Set rngzelle = Nothing

            End If
        End If
    Next
End Sub

Gruß
Nepumuk

Function rot_markieren() Dim sh As Worksheet Dim rngzelle as Range Dim lngZeile as Long lngZeile = 1 For Each sh In ActiveWorkbook.Worksheets If sh.Name "Übersicht" Then With Worksheets("Übersicht") 'Hier Name des Zielblattes anpassn For Each rngzelle In sh.Range("A1:HH50") 'Suchbereich anpassen If rngzelle.Interior.ColorIndex = 3 Then rngzelle.EntireRow.Copy .Cells(lngZeile, 1) lngZeile = lngZeile + 1 End If Next rngzelle End With End If Next End Function

Beliebteste Forumthreads (12 Monate)

Excel VBA Zellen einfügen ohne überschreiben

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

323 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Excel VBA Zellen einfügen ohne überschreiben

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

323 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread