Sub Zusammenfuehrungsvorschlag_erstellen() 'Tabellenname in "Eigentümer" ändern ActiveSheet.Name = "Eigentümer" 'zunächst werden alle Spalten gelöscht die nicht notwendig sind If Range("A1").Value = "PER_VEF_VKZF" Then Columns("BA:BG").Select Range("BG1").Activate Selection.Delete Shift:=xlToLeft Columns("AI:AY").Select Range("AY1").Activate Selection.Delete Shift:=xlToLeft Columns("O:AE").Select Range("AE1").Activate Selection.Delete Shift:=xlToLeft Columns("D:D").Select Selection.Delete Shift:=xlToLeft Selection.Delete Shift:=xlToLeft Columns("A:A").Select Selection.Delete Shift:=xlToLeft 'Spalte anlegen mit Anzahl der Eigentümer pro Grundbuchblatt Columns("C:C").Select Selection.Insert Shift:=xlToRight Range("C1").Select ActiveCell.FormulaR1C1 = "Anzahl_Eigentümer" Range("C2").Select End If 'Anschließend Sortierung nach der Beteiligung Cells.Select Range("F1").Activate Selection.Sort Key1:=Range("P2"), Order1:=xlAscending, Header:=xlYes, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal 'löschen der Flurstücke die nicht die Beteiligungskennung 1 haben i = 2 Do While Not Range("P" & i).Value = "" If Not Range("P" & i).Value = "1" Then Rows(i & ":" & i).Delete i = i - 1 End If i = i + 1 Loop ' PLZ alle 5stellig i = 2 Do While Not Range("A" & i).Value = "" If Len(Range("K" & i).Value) = 4 Then Range("K" & i).NumberFormat = "@" Range("K" & i).Value = "0" & Range("K" & i).Value End If i = i + 1 Loop 'Sortieren nach Flurstücken (Gemarkung, Zähler, Nenner) Cells.Select Range("F1").Activate Selection.Sort Key1:=Range("M2"), Order1:=xlAscending, Key2:=Range("N2") _ , Order2:=xlAscending, Key3:=Range("O2"), Order3:=xlAscending, Header:= _ xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _ xlSortNormal 'Anzahl der Personen pro Grundbuchblatt ermitteln i = 2 Do While Not Range("A" & i).Value = "" iBeginn = i Flurstueckcode = Range("M" & i).Value & Range("N" & i).Value & Range("O" & i).Value If Flurstueckcode = Range("M" & i + 1).Value & Range("N" & i + 1).Value & Range("O" & i + 1).Value Then y = i Do While Flurstueckcode = Range("M" & y + 1).Value & Range("N" & i + 1).Value & Range("O" & y + 1).Value i = i + 1 iEnde = i y = y + 1 Loop Else iEnde = i i = i + 1 End If For x = iBeginn To iEnde Range("C" & x).Value = iEnde - iBeginn + 1 Next i = iEnde + 1 Loop 'Sortieren nach Grundbuch und Person (Gemarkung; GB; Vorname) Cells.Select Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _ , Order2:=xlAscending, Key3:=Range("F2"), Order3:=xlAscending, Header:= _ xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _ xlSortNormal 'Doppelte Eigentümer pro GB löschen i = 2 Do While Not Range("A" & i).Value = "" If Range("A" & i).Value = Range("A" & i + 1).Value And Range("B" & i).Value = Range("B" & i + 1).Value And _ Range("G" & i).Value = Range("G" & i + 1).Value And Range("F" & i).Value = Range("F" & i + 1).Value Then Rows(i & ":" & i).Delete i = i - 1 End If i = i + 1 Loop 'Sortieren nach Person (Name; Vorname, gebDatum) Cells.Select Selection.Sort Key1:=Range("G2"), Order1:=xlAscending, Key2:=Range("F2") _ , Order2:=xlAscending, Key3:=Range("I2"), Order3:=xlAscending, Header:= _ xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _ xlSortNormal 'Temporäre Tabellen erzeugen Sheets.Add().Name = "tmp" Sheets.Add().Name = "tmp2" Sheets("Eigentümer").Select 'Zusammenführungsvorschläge erarbeiten i = 2 Do While Not Range("A" & i).Value = "" iBeginn = i If Range("G" & i).Value = Range("G" & i + 1).Value And Range("F" & i).Value = Range("F" & i + 1).Value And _ Range("C" & i).Value = Range("C" & i + 1).Value Then y = i Do While Range("G" & i).Value = Range("G" & y + 1).Value And Range("F" & i).Value = Range("F" & y + 1).Value And _ Range("C" & i).Value = Range("C" & y + 1).Value i = i + 1 iEnde = i y = y + 1 Loop For x = iBeginn To iEnde z1 = Range("A" & x).Value z2 = Range("B" & x).Value Sheets("tmp").Select Range("A" & x - iBeginn + 1).Value = z1 Range("B" & x - iBeginn + 1).Value = z2 Sheets("Eigentümer").Select Next Sheets("tmp").Select Columns("A:B").Select Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1") _ , Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:= _ False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _ :=xlSortNormal z3 = "" For x = iBeginn To iEnde If z3 = "" Then z3 = Range("A" & x - iBeginn + 1).Value & " - " & Range("B" & x - iBeginn + 1).Value Else z3 = z3 & " und " & Range("A" & x - iBeginn + 1).Value & " - " & Range("B" & x - iBeginn + 1).Value End If Next 'komplette Daten aus Tabelle tmp löschen Cells.Select Selection.ClearContents 'Abfrage, welche nächste Zeile frei ist Sheets("tmp2").Select i3 = 1 Do While Not Range("A" & i3).Value = "" i3 = i3 + 1 Loop 'kompletten Zusammenführungsvorschlag eintragen Range("A" & i3).Value = z3 'zurück zur Tabelle Eigentümer Sheets("Eigentümer").Select i = iEnde + 1 Else i = i + 1 End If Loop 'Tabelle tmp2 sortieren Sheets("tmp2").Select Columns("A:A").Select Selection.Sort Key1:=Range("A1"), Order1:=xlAscending _ , Header:=xlNo, OrderCustom:=1, MatchCase:= _ False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _ :=xlSortNormal 'Doppelte Zusammenführungsvorschläge löschen und alle in eine Variable schreiben i4 = 1 Do While Not Range("A" & i4).Value = "" If Range("A" & i4).Value = Range("A" & i4 + 1).Value Then Rows(i4 & ":" & i4).Delete Else If a = "" Then a = Range("A" & i4).Value Else a = a & vbCrLf & vbCrLf & Range("A" & i4).Value End If i4 = i4 + 1 End If Loop Sheets("Eigentümer").Select 'Temporäre Tabellen löschen Application.DisplayAlerts = False Sheets("tmp").Delete Sheets("tmp2").Delete Application.DisplayAlerts = True CreateAfile (a) End Sub Sub CreateAfile(Text) Set AppShell = CreateObject("Shell.Application") Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen zum Speichern der Datei Eigentuemerpruefung.txt", &H1000, 17) On Error Resume Next Pfad = BrowseDir.items().Item().Path If Not Right(Pfad, 1) = "\" Then Pfad = Pfad & "\" End If If Pfad = "" Then MsgBox "Die Routine wird abgebrochen, weil kein Pfad ausgewählt wurde" Exit Sub End If On Error GoTo 0 text2 = Zusammenführungsvorschlag & vbNewLine & vbNewLine & _ "Die hier je Zeile (getrennt durch eine Leerzeile) aufgelisteten Grundbücher könnten zu einer Besitzstandsnummer zusammengeführt werden. " & _ "Die erste Zahl ist der Grundbuchbezirk, die zweite Zahl nach dem '-' die Grundbuchblattnummer. " & _ "Voraussetzung für das korrekte Arbeiten des Programmes ist die identische Schreibweise von gleichen Personen." & _ vbNewLine & vbNewLine & Text Set fs = CreateObject("Scripting.FileSystemObject") Set a = fs.CreateTextFile(Pfad & "Zusammenführung.txt", True) a.WriteLine (text2) a.Close zzz = Shell("notepad.exe " & Pfad & "Zusammenführung.txt", vbNormalFocus) End Sub