Guten Tag,

hier werden bei gleicher Straße und gleicher Bezirk die Hausnummern zusammengefasst. Dies funktioniert auch nur dauert dies bei ca. 40000 Datensätzen ca. 10 Minuten. Kann ich dies irgendwo noch optimieren oder verbessern? Ich bin für jede Hilfe dankbar.

Sub Gerade_Nr_Verdichten_Test()

    'Mehrere gerade HNr. werden jeweils bei einer
    'Straße und gleicher PLZ und Bezirk zu einer Zeile verdichtet
    
    Dim i As Currency
    Dim iEnde As Currency
    'Dim y As Integer 'Laufparameter für g und u
    Dim PLZ As String
    Dim PLZ1 As String
    
    Dim Straße As String
    Dim Straße1 As String
    Dim Pari As String
    Dim Pari1 As String
    Dim ZBez As String
    Dim ZBez1 As String
    Dim HNvonMin As Integer
    'Dim HNbisMin As Integer
    Dim HNbisMax As Integer
    'Dim HNbisMax1 As Integer
    Dim z As Currency
    Dim AnzahlLöschen As Currency
    Dim nStartabsolut As Currency
    Dim nStart As Currency
    Dim nEnde As Currency
    
    Application.ScreenUpdating = False ' Bildaktualisierung deaktivieren
   Application.Calculation = xlCalculationManual 'Berechnung ausschalten
    Sheets("Arbeitsdatei").Select
    'iEnde = i + i
    
    iEnde = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    
   
    
    'Erste Schleife für gerade HNr
        For i = 2 To iEnde
        Ergebnis = ""
        PLZ = Cells(i, 1).Value
        Straße = Cells(i, 7).Value
        Pari = Cells(i, 4).Value
        ZBez = Cells(i, 11).Value
        Cells(i, 22).Select
        
            If Pari = "G" Then
            HNvonMin = Cells(i, 5).Value
            nStartabsolut = i 'Start Schleife löschen
            nStart = i 'Laufparameter für Schleifenende Löschung
            PLZ1 = Cells(nStart + 1, 1).Value
            Straße1 = Cells(nStart + 1, 7).Value
            Pari1 = Cells(nStart + 1, 4).Value
                        
                'Falls PLZ1="", dann Ende des Tools
                If PLZ1 = "" Then
                GoTo Ende
                End If
               
                        Do Until Ergebnis = "nicht ok"
                        PLZ1 = Cells(nStart + 1, 1).Value
                        Straße1 = Cells(nStart + 1, 7).Value
                        Pari1 = Cells(nStart + 1, 4).Value
                        ZBez1 = Cells(nStart + 1, 11).Value
                            
                            If PLZ = PLZ1 And Straße = Straße1 And Pari = Pari1 And ZBez = ZBez1 Then
                             Ergebnis = "ok"
                            Else
                            Ergebnis = "nicht ok"
                            End If
                            
                        nStart = nStart + 1
                        Loop
            
                        nEnde = nStart - 1
                            
                            If nEnde = i - 2 Then
                            GoTo Nexti
                            End If
            
                        'Ermittlung HNbisMax aus letzter Zeile
                        'HNbisMax = Cells(nEnde, 6).Value
                        HNbisMax = Cells(nEnde, 5)
            
                                If HNbisMax > HNbisMax Then
                                HNbisMax = HNbisMax
                                Cells(nStartabsolut, 5).Value = HNbisMax
                                Else
                                HNbisMax = HNbisMax
                                Cells(nStartabsolut, 6).Value = HNbisMax
                                End If
                
                            'Überflüssige Zeilen löschen
                            AnzahlLöschen = nEnde - nStartabsolut
                            
                            For z = 1 To AnzahlLöschen
                            Range(Cells(nStartabsolut + 1, 1), Cells(nStartabsolut + 1, 22)).Select
                            Selection.Delete Shift:=xlUp
                            Next z
            
                                i = nStartabsolut
Nexti:
            End If
        Next i
Ende:

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True ' Bildaktualisierung wieder aktivieren
End Sub