Public Pfad As String

Sub Plausi_Eigentuemerpruefung()

'Der Nutzer muss zunächst auswählen, wo die Textdatei abgespeichert werden soll
    Dim AppShell As Object
    Dim BrowseDir As Variant
    
    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

    txt_WriteAll "Die Datei soll Fehler in Eigentümerdaten leichter finden. Nicht jeder Hinweis ist ein Fehler." & _
                "Vor jedem Hinweis steht eine Nummer in eckigen Klammern [x]. Die Hinweismeldungen werden hier erläutert:" & vbNewLine & vbNewLine & _
                "[1] - Wenn das Geburtsjahr kleiner als 1850 oder größer als das jetzige Jahr ist, dann erscheint diese Meldung." & vbNewLine & _
                "[2] - Wenn Personen mit gleichen Vornamen unterscheidliche Anreden besitzen, erscheint der Hinweis" & vbNewLine & _
                "[3] - Wenn der gleiche Eigentümer (Prüfung nach Geburtsdatum und Nachname) andere Werte (Anrede, Vorname, Titel, Geburtsname, Straße, PLZ und Ort) besitzt, dann diese Meldung" & vbNewLine & _
                "[4] - Wenn Anrede, Vorname und Name nicht leer ist aber beim Geburtsdatum oder/und Straße oder/und PLZ oder/und Ort kein Entrag steht, dann diese Meldung" & vbNewLine & _
                "[5] - Diese Meldung erscheint immer. Es erfolgt eine automatisierte Angleichung der Straßennamen um per Code vergleichen zu können" & vbNewLine & _
                "[6] - Wenn gleicher Straßennamen (ohne Hausnummer) unterscheidliche PLZ oder Ort dann diese Meldung" & vbNewLine & _
                "[7] - Wenn der gleiche Ort unterschiedliche PLZ hat, dann diese Meldung" & vbNewLine & vbNewLine & _
                "----------------------------------------------------------------------------------------" & vbNewLine & vbNewLine

    'Tabellenname in "Eigentümer" ändern
    ActiveSheet.Name = "Eigentümer"

    a = MsgBox("Sollen nur die Eigentümer berücksichtigt werden, die am Verfahren beteiligt sind? (Es empfiehlt sich alle Eigentümer zu berücksichtigen --> klicke NEIN)", vbYesNo)
    If a = vbYes Then
        'Sortierung nach der Beteiligung
            Cells.Select
            Selection.Sort Key1:=Range("AZ2"), 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("AZ" & i).Value = ""
                If Not Range("AZ" & i).Value = "1" Then
                  Rows(i & ":" & i).Delete
                  i = i - 1
                End If
                i = i + 1
            Loop
    End If

    'zunächst werden alle Spalten gelöscht die nicht notwendig sind
    If Range("A1").Value = "PER_VEF_VKZF" Then
        Columns("O:BG").Select
        Range("BG1").Activate
        Selection.Delete Shift:=xlToLeft
        Columns("A:E").Select
        Range("E1").Activate
        Selection.Delete Shift:=xlToLeft
    End If


    
    
' PLZ alle 5stellig
    i = 2
    Do While Not Range("D" & i).Value = "" Or Not Range("D" & i + 1).Value = "" Or Not Range("D" & i + 2).Value = ""
        If Len(Range("H" & i).Value) = 4 Then
            Range("H" & i).NumberFormat = "@"
            Range("H" & i).Value = "0" & Range("H" & i).Value
        End If
        'Geburtsdatum auf Plausibilität prüfen
        If Not Range("F" & i).Value = "" Then
            If Right(Range("F" & i).Value, 4) < "1850" Or Format(Range("F" & i).Value, "yyyy") > Format(Now, "yyyy") Then
                 txt_AppendLine "[1] Das Geburtsdatum (" & Range("F" & i).Value & ") des Eigentümers " & Range("C" & i).Value & " " & Range("D" & i).Value & " kann nicht stimmen"
            End If
        End If
        i = i + 1
    Loop

'Sortieren nach Vorname und Anrede
    Cells.Select
    Selection.Sort Key1:=Range("C2"), Order1:=xlAscending, Key2:=Range("A2") _
        , Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _
        , Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
        xlSortNormal
        
'Wenn der gleiche Vorname eine andere Anrede besitzt, dann Meldung
    i = 2
    iBeginn = 0
    iEnde = 0
    Do While Not Range("C" & i + 1).Value = ""
        If Range("C" & i).Value = Range("C" & i + 1).Value Then
            iBeginn = i
            Do While Range("C" & i).Value = Range("C" & i + 1).Value
                i = i + 1
                iEnde = i
            Loop
            
            gleiche_Anrede = True
            For x = iBeginn To iEnde
                If Not Range("A" & x).Value = Range("A" & iBeginn).Value Then
                    gleiche_Anrede = False
                    Exit For
                End If
            Next
            
            If gleiche_Anrede = False Then
                txt_AppendLine "[2] Personen mit dem Vornamen " & Range("C" & x).Value & " sind mit unterschiedlichen Anreden gespeichert"
            End If
        Else
            i = i + 1
        End If
    Loop

'Wenn der gleiche Eigentümer (Prüfung nach Geburtsdatum und Nachname) andere Werte (Anrede, Vorname, Titel, Geburtsname, Straße, PLZ und Ort) besitzt, dann Meldung
    Cells.Select
    Selection.Sort Key1:=Range("F2"), Order1:=xlAscending, Key2:=Range("D2") _
        , Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _
        , Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
        xlSortNormal
        
    i = 2
    iBeginn = 0
    iEnde = 0
    Do While Not Range("D" & i + 1).Value = "" Or Not Range("D" & i + 2).Value = ""
        If Range("F" & i).Value = Range("F" & i + 1).Value And Range("D" & i).Value = Range("D" & i + 1).Value Then
            iBeginn = i
            Do While Range("F" & i).Value = Range("F" & i + 1).Value And Range("D" & i).Value = Range("D" & i + 1).Value
                i = i + 1
                iEnde = i
            Loop
            
            gleiche_Anrede = True
            gleicher_Vorname = True
            gleicher_Titel = True
            gleicher_Geburtsname = True
            gleiche_Straße = True
            gleiche_PLZ = True
            gleicher_Ort = True
            For x = iBeginn To iEnde
                If Not Range("A" & x).Value = Range("A" & iBeginn).Value Then
                    gleiche_Anrede = False
                End If
                If Not Range("B" & x).Value = Range("B" & iBeginn).Value Then
                    gleicher_Titel = False
                End If
                If Not Range("C" & x).Value = Range("C" & iBeginn).Value Then
                    gleicher_Vorname = False
                End If
                If Not Range("E" & x).Value = Range("E" & iBeginn).Value Then
                    gleicher_Geburtsname = False
                End If
                If Not Range("G" & x).Value = Range("G" & iBeginn).Value Then
                    gleiche_Straße = False
                End If
                If Not Range("H" & x).Value = Range("H" & iBeginn).Value Then
                    gleiche_PLZ = False
                End If
                If Not Range("I" & x).Value = Range("I" & iBeginn).Value Then
                    gleicher_Ort = False
                End If
            Next
            
            If gleiche_Anrede = False Or gleicher_Vorname = False Or gleicher_Titel = False Or gleicher_Geburtsname = False Or gleiche_Straße = False Or gleiche_PLZ = False Or gleicher_Ort = False Then
                tmp_text = "Der Eigentümer mit dem Geburtsdatum " & Range("F" & iBeginn).Value & " und dem Nachnamen " & Range("D" & iBeginn).Value & " steht in der Tabelle mit unterschiedlichen "
                    If gleiche_Anrede = False Then
                        tmp_text = tmp_text & "Anrede, "
                    End If
                    If gleicher_Vorname = False Then
                        tmp_text = tmp_text & "Vornamen, "
                    End If
                    If gleicher_Titel = False Then
                        tmp_text = tmp_text & "Titel, "
                    End If
                    If gleicher_Geburtsname = False Then
                        tmp_text = tmp_text & "Geburtsname, "
                    End If
                    If gleiche_Straße = False Then
                        tmp_text = tmp_text & "Straße, "
                    End If
                    If gleiche_PLZ = False Then
                        tmp_text = tmp_text & "PLZ, "
                    End If
                    If gleicher_Ort = False Then
                        tmp_text = tmp_text & "und Ort"
                    End If
                txt_AppendLine "[3] " & tmp_text
            End If
                         
            'Wenn Anrede, Vorname und Name nicht leer ist aber beim Geburtsdatum oder/und Straße oder/und PLZ oder/und Ort kein Entrag steht, dann Meldung
            If Not Range("A" & iBeginn).Value = "" And Not Range("C" & iBeginn).Value = "" And Not Range("D" & iBeginn).Value = "" Then
                If Range("F" & iBeginn).Value = "" Or Range("G" & iBeginn).Value = "" Or Range("H" & iBeginn).Value = "" Or Range("I" & iBeginn).Value = "" Then
                    tmp_text = "Die Person mit dem Namen " & Range("C" & iBeginn).Value & " " & Range("D" & iBeginn).Value & " steht in der Tabelle ohne "
                    If Range("F" & iBeginn).Value = "" Then
                        tmp_text = tmp_text & "Geburtsdatum, "
                    End If
                    If Range("G" & iBeginn).Value = "" Then
                        tmp_text = tmp_text & "Straße, "
                    End If
                    If Range("H" & iBeginn).Value = "" Then
                        tmp_text = tmp_text & "PLZ "
                    End If
                    If Range("I" & iBeginn).Value = "" Then
                        tmp_text = tmp_text & "und Ort "
                    End If
                    txt_AppendLine "[4] " & tmp_text
                End If
            End If

        Else
            'Wenn Anrede, Vorname und Name nicht leer ist aber beim Geburtsdatum oder/und Straße oder/und PLZ oder/und Ort kein Entrag steht, dann Meldung
            If Not Range("A" & i).Value = "" And Not Range("C" & i).Value = "" And Not Range("D" & i).Value = "" Then
                If Range("F" & i).Value = "" Or Range("G" & i).Value = "" Or Range("H" & i).Value = "" Or Range("I" & i).Value = "" Then
                    tmp_text = "Die Person mit dem Namen " & Range("C" & i).Value & " " & Range("D" & i).Value & " steht in der Tabelle ohne "
                    If Range("F" & i).Value = "" Then
                        tmp_text = tmp_text & "Geburtsdatum, "
                    End If
                    If Range("G" & i).Value = "" Then
                        tmp_text = tmp_text & "Straße, "
                    End If
                    If Range("H" & i).Value = "" Then
                        tmp_text = tmp_text & "PLZ "
                    End If
                    If Range("I" & i).Value = "" Then
                        tmp_text = tmp_text & "und Ort "
                    End If
                    txt_AppendLine "[4] " & tmp_text
                End If
            End If
            i = i + 1
        End If
        
    Loop
        
    
'Sortieren nach Straße und alle Straßenschreibweisen vereinheitlichen (str.; Str.; strasse; Strasse in Straße ändern)
    Cells.Select
    Selection.Sort Key1:=Range("G2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    
    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight

    i = 2
    Do While Not Range("G" & i).Value = ""
        tmp_InhaltZelleVorher = Range("G" & i).Value
        If Range("G" & i).Value Like "*str.*" Then
            Range("G" & i).Replace "str.", "straße"
        End If
        If Range("G" & i).Value Like "*Str.*" Then
            Range("G" & i).Replace "Str.", "Straße"
        End If
        If Range("G" & i).Value Like "*strasse*" Then
            Range("G" & i).Replace "strasse.", "straße"
        End If
        If Range("G" & i).Value Like "*Strasse*" Then
            Range("G" & i).Replace "Strasse", "Straße"
        End If
        
        tmp_straße = ""
        tmp_StraßeohneHausnummer = False
        For i2 = 1 To Len(Range("G" & i).Value)
            If IsNumeric(Mid$(Range("G" & i).Value, i2, 1)) Then
                If i2 = 1 Then Exit For
                If Not tmp_StraßeohneHausnummer = True Then
                    Range("H" & i).Value = RTrim(tmp_straße)
                    tmp_StraßeohneHausnummer = True
                End If
                If Not IsNumeric(Mid$(Range("G" & i).Value, i2 - 1, 1)) And Not Mid$(Range("G" & i).Value, i2 - 1, 1) = " " Then
                    tmp_straße = tmp_straße & " "
                End If
                
                tmp_straße = tmp_straße & Mid$(Range("G" & i).Value, i2, 1)
                
                If Not i2 = Len(Range("G" & i).Value) Then
                    If Not IsNumeric(Mid$(Range("G" & i).Value, i2 + 1, 1)) And Not Mid$(Range("G" & i).Value, i2 + 1, 1) = " " Then
                        tmp_straße = tmp_straße & " "
                        'i2 = i2 + 1
                    End If
                End If
            Else
                tmp_straße = tmp_straße & Mid$(Range("G" & i).Value, i2, 1)
            End If
        Next
        Range("G" & i).Value = tmp_straße
        tmp_InhaltZelleNachher = Range("G" & i).Value
        
        If Not tmp_InhaltZelleVorher = tmp_InhaltZelleNachher Then
            Range("G" & i).Interior.ColorIndex = 36
            Range("G" & i).AddComment
            Range("G" & i).Comment.Visible = False
            Range("G" & i).Comment.Text Text:="Wert vorher: " & tmp_InhaltZelleVorher & Chr(10) & "Wert nachher: " & tmp_InhaltZelleNachher
            Range("G" & i + 1).Select
        End If
        
        i = i + 1
    Loop

txt_AppendLine "[5] - Zur Datenverarbeitung wurde der Straßenname vereinheitlicht. Änderungen in der Exceltabelle sind gelb hinterlegt. Im Kommentarfeld können Sie die automatisierte Änderung verfolgen. Entscheiden Sie selber ob Sie die Änderung im AGLB übernehmen."

'Wenn gleicher Straßennamen in angelegter Spalte H (ohne Hausnummer) unterscheidliche PLZ oder Ort dann Meldung
    i = 2
    iBeginn = 0
    iEnde = 0

    Do While Not Range("H" & i).Value = ""
        If Range("H" & i).Value = Range("H" & i + 1).Value Then
            iBeginn = i
            Do While Range("H" & i).Value = Range("H" & i + 1).Value
                i = i + 1
                iEnde = i
            Loop
            
            gleiche_PLZ = True
            gleicher_Ort = True
            For x = iBeginn To iEnde
                If Not Range("I" & x).Value = Range("I" & iBeginn).Value Then
                    gleiche_PLZ = False
                End If
                If Not Range("J" & x).Value = Range("J" & iBeginn).Value Then
                    gleicher_Ort = False
                End If
            Next
            
            If gleiche_PLZ = False Or gleicher_Ort = False Then
                tmp_text = "Die Straße mit dem Namen " & Range("H" & iBeginn).Value & " steht in der Tabelle mit unterschiedlichen "
                    If gleiche_PLZ = False Then
                        tmp_text = tmp_text & "PLZ "
                    End If
                    If gleicher_Ort = False Then
                        tmp_text = tmp_text & "und Ort"
                    End If
                txt_AppendLine "[6] " & tmp_text
            End If
            
        Else
            i = i + 1
        End If
    Loop

    Columns("H:H").Select
    Selection.Delete Shift:=xlToLeft

'Sortieren nach Ort und PLZ, anschließend Meldung ausgeben, wenn der gleiche Ort unterschiedliche PLZ hat
    Cells.Select
    Selection.Sort Key1:=Range("I2"), Order1:=xlAscending, Key2:=Range("H2") _
        , Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _
        , Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
        xlSortTextAsNumbers
        
    i = 2
    iBeginn = 0
    iEnde = 0

    Do While Not Range("I" & i).Value = ""
        If Range("I" & i).Value = Range("I" & i + 1).Value Then
            iBeginn = i
            Do While Range("I" & i).Value = Range("I" & i + 1).Value
                i = i + 1
                iEnde = i
            Loop
            
            gleiche_PLZ = True
            For x = iBeginn To iEnde
                If Not Range("H" & x).Value = Range("H" & iBeginn).Value Then
                    gleiche_PLZ = False
                End If
            Next
            
            If gleiche_PLZ = False Then
                txt_AppendLine "[7] Der Ort mit dem Namen " & Range("I" & iBeginn).Value & " steht in der Tabelle mit unterschiedlichen PLZ"
            End If
            
        Else
            i = i + 1
        End If
    Loop
        
zzz = Shell("notepad.exe " & Pfad & "Eigentuemerpruefung.txt", vbNormalFocus)

End Sub

' Einzelne Zeile an eine Textdatei anhängen
' sFilename:  vollständiger Name der Datei
' sLine    :  Inhalt, der gespeichert werden soll
' ===============================================
Public Sub txt_AppendLine(ByVal sLine As String)
 
  Dim F As Integer
 
  ' Datei zum "Anhängen" von Daten öffnen
  ' und Textzeile ans Ende anfügen
  F = FreeFile
  Open Pfad & "Eigentuemerpruefung.txt" For Append As #F
  Print #F, sLine
  Close #F
End Sub

' Beliebigen Text in eine Textdatei speichern, wobei
' der bisherige Inhalt der Textdatei vollständig
' überschrieben wird
'
' sFilename:  vollständiger Dateiname
' sLines   :  Inhalt, der gespeichert werden soll
' ===============================================
Public Sub txt_WriteAll(ByVal sLines As String)
 
  Dim F As Integer
 
  ' Datei zum Schreiben öffnen
  ' Achtung: bisheriger Inhalt wird gelöscht!
  F = FreeFile
  Open Pfad & "Eigentuemerpruefung.txt" For Output As #F
  Print #F, sLines
  Close #F
End Sub