|
Danke Ralf_b,
dass mit dem Array hatte ich auch schon überlegt, aber davon überhaupt keine Ahnung.
Ich habe jetzt durch nachlesen etwas angefangen, was natürlich so nicht funktioniert :-(
Kann mir da jemand helfen?
Sub Gerade_Nr_Verdichten_mit_array()
'Mehrere gerade HNr. werden jeweils bei einer
'Straße und gleicher PLZ 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
Dim arr As Variant
Dim rngData As Range
arr = Array(PLZ, Straße, Pari, ZBez, , ZBez1, HNvonMin, HNbisMax, nStartabsolut, nStart, PLZ1, Straße1, Pari1, AnzahlLöschen, nEnde)
Application.ScreenUpdating = False ' Bildaktualisierung deaktivieren
Application.Calculation = xlCalculationManual 'Berechnung ausschalten
Sheets("Arbeitsdatei").Select
'iEnde = i + i
Set rngData = ActiveSheet.Range("A1").CurrentRegion
'iEnde = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Array dimensioniern und füllen
ReDim arr(1 To rngData.Rows.Count, 1 To rngData.Columns.Count)
arr = rngData.Value
'Erste Schleife für gerade HNr
For i = 2 To UBound(arr, 1)
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
HNbisMax1 = Cells(nEnde, 5)
If HNbisMax > HNbisMax1 Then
HNbisMax = HNbisMax
Cells(nStartabsolut, 6).Value = HNbisMax
Else
HNbisMax = HNbisMax1
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
|