Klappt einwandfrei
15.05.2006 15:18:33
Frank
Hallo Reinhard!
Die Routine arbeitet einwandfrei. Vielen Dank für die Hilfe.
Für Interessierte habe ich hier mal das ganze Modul gelistet:
(Teilweis im Kommentar noch mir der Version "On Error goto")
Hier nun das Modul:
Sub Zuordnung()
Dim bz As Integer 'Zähler für benutzte Reihen
Dim bz2 As Integer 'Zähler für benutzte Reihen
Dim i As Integer 'Schleifendurchlaufzähler
Dim Hnr As Integer 'Zahl für die Hausnummer aus dem Tabellenblatt Discovererfehler
Dim Hnr2 As Integer 'Zahl für die Hausnummer aus dem Tabellenblatt Straßenreferenz
Dim R As Integer 'Wert für den Rest der Division der Hausnummer geteilt durch 2 (wird benötigt, um festzustellen, ob die Hausnummer eine gerade oder ungerade Zahl ist)
Dim GU As String 'Bestimmung ob Hausnummer aus Tabellenblatt Discovererfehler gerade oder ungerade ist
Dim GU2 As String 'Bestimmung ob Hausnummer aus Tabellenblatt Straßenreferenz gerade oder ungerade ist
Dim Strasse As String 'Liest den Straßennamen aus dem Tabellenblatt Discovererfehler ein
Dim Zeile As Integer 'Wert für die Bestimmung einer Zeilennummer
Dim Abbruch As Byte 'Variable die bestimmt, wann die Schleife beendet werden kann
Dim Feld(5) As String 'Variablenblock für die zu übergebenden Werte von PLZ, Stadttei, PI und TOF
Dim j As Integer 'Schleifendurchlaufzähler "plus"
Dim dummy As Integer 'Zähler für die Dummystraßen
Dim Antwort As Byte
Application.StatusBar = "Berechnung läuft, bitte warten."
Application.ScreenUpdating = False
'On Error GoTo Fehler
bz = ActiveWorkbook.Sheets("Discovererfehler").UsedRange.Rows.Count
For i = 2 To bz
ActiveWorkbook.Sheets("Discovererfehler").Select
Hnr = Cells(i, 9) 'Liest die Hausnummer aus dem Tabellenblatt Discovererfehlerblatt aus
R = Hnr Mod 2 'Mod2 teilt den Wert Hnr durch 2
If R = 0 Then
GU = "Gerade"
Else
GU = "Ungerade"
End If
Strasse = Cells(i, 8) 'Liest die Straße neben der zuvor ermittelten Hausnummer aus dem Tabellenblatt Discovererfehler aus
Worksheets("Straßenreferenz").Select
'Range("A12").Select 'Erste Straße des Tabellenblattes Straßenreferenz wirsd ausgewält
Columns("A:A").Select
'Hier wird der zuvor in die Variable "Straße" eingelesene Wert gesucht
If Application.WorksheetFunction.CountIf(Columns("A:A"), Strasse) > 0 Then
Cells.Find(What:=Strasse, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole _
, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Activate
Zeile = ActiveCell.Row 'Die Zeilennummer wird hier gemerkt
Abbruch = 0 'Hier wird zunächst einmal davon ausgegangen, dass die gesuchte Straße gefunden wurde
'Nun läuft eine nächste Schleife an, die die Hausnummern vergleicht
Do While Abbruch = 0
Hnr2 = Cells(Zeile, 3) 'Liest die Hausnummer aus dem Tabellenblatt Straßenreferenz aus
R = Hnr2 Mod 2 'Mod2 teilt den Wert Hnr2 durch 2
If R = 0 Then
GU2 = "Gerade"
Else
GU2 = "Ungerade"
End If
'Jetzt werden die eingelesenen Hausnummern verglichen
'Wenn die Werte passen, werden sie übernommen und die Variable "Abbruch" erhält den Wert 1
'Damit wird die Schleife beendet, ansonsten wird die Variable "Zeile" einen Wert heraufgesetzt
'Der Loop würde erneut durchlaufen
If GU = "Gerade" And GU2 = "Gerade" And Hnr <= Hnr2 Then
Feld(1) = Cells(Zeile, 4) 'Postleitzahl
Feld(2) = Cells(Zeile, 5) 'Ort (ist immer Düsseldorf, wird aus technischen Gründen für Feld benötigt)
Feld(3) = Cells(Zeile, 6) 'Stadtteil
Feld(4) = Cells(Zeile, 7) 'PI
Feld(5) = Cells(Zeile, 8) 'Tatortfahndungsbereich neu (beinhaltet auch BD)
Abbruch = 1 '
ElseIf GU = "Ungerade" And GU2 = "Ungerade" And Hnr <= Hnr2 Then
Feld(1) = Cells(Zeile, 4) 'Postleitzahl
Feld(2) = Cells(Zeile, 5) 'Ort (ist immer Düsseldorf, wird aus technischen Gründen für Feld benötigt)
Feld(3) = Cells(Zeile, 6) 'Stadtteil
Feld(4) = Cells(Zeile, 7) 'PI
Feld(5) = Cells(Zeile, 8) 'Tatortfahndungsbereich neu (beinhaltet auch BD)
Abbruch = 1
End If
Zeile = Zeile + 1
Loop
'Hier müssen nun die ermittelten Werte noch an das Tabelenblatt "Discovererfehler" übergeben werden
Worksheets("Discovererfehler").Select
For j = 1 To 5
Cells(i, j + 9) = Feld(j)
Next j
'Hier läuft die Neufehlererkennung an, falls der eingelesene Straßenwert nicht in der Referenz war
Else
MsgBox i
bz2 = ActiveWorkbook.Sheets("undefinierte_fehler").UsedRange.Rows.Count
ActiveWorkbook.Sheets("Discovererfehler").Rows(i).Copy ActiveWorkbook.Sheets("undefinierte_fehler").Rows(bz2 + 1)
ActiveWorkbook.Sheets("Discovererfehler").Rows(i).Delete
i = i - 1 'Da Fehlerzeile aus Tabellenblatt "Discovererfehler" gelöscht wurde muss der Schleifenwert i zurücgesetzt werden!
Antwort = MsgBox("Es wurde ein Neufehler erkannt:" _
& vbCrLf & vbCrLf _
& Strasse _
& vbCrLf & vbCrLf & vbCrLf _
& "Der Fehler muss im Quellcode ausprogrammiert werden." _
& "Wollen Sie den Suchlauf beenden?", vbQuestion + vbYesNo, "ACHTUNG:")
If Antwort = 6 Then
Worksheets("Discovererfehler").Select
Cells(i, 8).Select
Unload frm_Fehlerkorrektur
Unload frm_Einlesen
Application.ScreenUpdating = True
Application.StatusBar = False
Exit Sub
Else
MsgBox "Fehlerkorrektur wird fortgesetzt"
End If
End If
'Hier läuft die große Schleife mit der nächsten Straße erneut an
Next i
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox "Routine beendet."
Exit Sub
'Fehler:
''Hier werden die neu erkannten Fehler verschoben
'bz2 = ActiveWorkbook.Sheets("undefinierte_fehler").UsedRange.Rows.Count
'ActiveWorkbook.Sheets("Discovererfehler").Rows(i).Copy ActiveWorkbook.Sheets("undefinierte_fehler").Rows(bz2 + 1)
'ActiveWorkbook.Sheets("Discovererfehler").Rows(i).Delete
'Antwort = MsgBox("Es wurde ein Neufehler erkannt:" _
' & vbCrLf & vbCrLf _
' & Strasse _
' & vbCrLf & vbCrLf & vbCrLf _
' & "Der Fehler muss im Quellcode ausprogrammiert werden." _
' & "Wollen Sie den Suchlauf beenden?", vbQuestion + vbYesNo, "ACHTUNG:")
' If Antwort = 6 Then
' Worksheets("Discovererfehler").Select
' Cells(i, 8).Select
' Unload frm_Fehlerkorrektur
' Unload frm_Einlesen
' Else
' MsgBox "Fehlerkorrektur wird nochmals gestartet"
' Call Strassen
' Call Zuordnung
' End If
'Application.ScreenUpdating = True
'Application.StatusBar = False
End Sub