VBA Excel Filter mit vor Definiertem Freien Platz

Sub CopyUniqueToSheets()

     'Alle Leeren Einträge mit etwas Füllen keine Datei mit Leeren Namen erstellt werden kann   
    Columns("G:G").Select  
    Selection.Replace What:="", Replacement:="empty", LookAt:=xlPart, _  
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False



    Dim ws As Worksheet, newWS As Worksheet, cell As Range, dic As Object, c As Range
    'Dictionary-Objekt erzeugen  
    Set dic = CreateObject("Scripting.Dictionary")  
    'Worksheet festlegen in dem die Daten liegen  
    Set ws = Sheets(1)
    'letze Zeile ermitteln  
    lastRow = ws.UsedRange.Rows.Count
    
    For Each cell In ws.Range("G25:G" & lastRow)  
        'Wenn der Zustand in der aktuellen Zelle noch nicht verarbeitet wurde  
        If Not dic.Exists(cell.Value) Then
            'Zustand zum Dictionary hinzufügen  
            dic.Add cell.Value, ""  
            'neues Worksheet hinzufügen  
            Set newWS = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            'dem Worksheet den Namen des Zustandes geben  
            newWS.Name = cell.Value
            'Überschriftenzeile übertragen  
            ws.Range("A24").EntireRow.Copy newWS.Range("A24")  
            'Suche in Spalte G  
            With ws.Range(cell, "G" & lastRow)  
                'Suche den Zustand in der aktuellen Zelle  
                Set c = .Find(cell.Value, LookIn:=xlValues)
                If Not c Is Nothing Then
                    firstAddress = c.Address
                    Do
                        'Eintrag gefunden, kopiere die gefundene Zeile ins neue Sheet ans Ende  
                        c.EntireRow.Copy newWS.UsedRange.Cells(newWS.UsedRange.Rows.Count + 1, 1)
                        'Suche den nächsten Eintrag  
                        Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> firstAddress
                End If
            End With
        End If    
    Next
 MsgBox "Its Done"  
End Sub