' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set objADO = Nothing
End Sub
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Public objADO As Object
Public Sub initializeADO()
If objADO Is Nothing Then _
Set objADO = ExcelTable("E:\Forum\Postleitzahlen.xlsx", "Postleitzahlen", "A1:L15000")
End Sub
Public Function ExcelTable(ByVal Path As String, ByVal Table As String, ByVal SourceRange As _
String, Optional ByVal WhereString As String = "", Optional ByVal SelectString As String = "*") As Object
Dim SQL As String
Dim Con As String
'Liest Daten aus einer Excel-Tabelle mit Hilfe einer SQL-Abrage aus, die Tabelle muss dabei den Kriterien einer Dabtenbak
'entsprechen. Also eine Überschriftenzeile mit eintdeutigen Überschriften,
'keine leeren Zeilen und in jeder Spalte nur ein Datentyp.
On Error GoTo ErrorHandler
If ((GetAttr(Path) And vbDirectory) <> vbDirectory) Then
SQL = "SELECT " & SelectString & " FROM [" & Table & "$" & SourceRange & "] " & WhereString
If Mid(Path, InStrRev(Path, ".") + 1) = "xls" Then
Con = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & "Data Source=" & _
Path & ";"
ElseIf Mid(Path, InStrRev(Path, ".") + 1) Like "xls?" Then
Con = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0;HDR=YES"";" & _
"Data Source=" & Path & ";"
Else
GoTo ErrorHandler
End If
Set ExcelTable = CreateObject("ADODB.Recordset")
ExcelTable.Open SQL, Con, 3, 1
Exit Function
End If
ErrorHandler:
Set ExcelTable = Nothing
End Function
Sub showForm()
UserForm1.Show
End Sub
' **********************************************************************
' Modul: UserForm1 Typ: Userform
' **********************************************************************
Option Explicit
Private bolAction As Boolean
Private Sub cboOrt_Change()
Dim lngI As Long
On Error Resume Next
'bolAction ist eine Hilfsvariable um mehrfachaufruf des Codes zu unterbinden
If Not bolAction Then Exit Sub
'bolAction auf Falsch setzen
bolAction = False
With cboTeil
'Prüfen obj das ADO-Object exstiert
If objADO Is Nothing Then Call initializeADO
'Recordset des ADO-Objectes nach der PLZ filtern
objADO.Filter = "Ort='" & cboOrt.Text & "'"
If Not objADO.EOF Then
'Combobox für die Ortsteile leeren
.Clear
For lngI = 2 To objADO.Fields.Count - 1
'Wenn Ortsteile vorhanden, dann in Combobox schreiben
If Not IsNull(objADO.Fields(lngI).Value) Then
.AddItem objADO.Fields(lngI).Value
End If
Next
'Wenn Einträge vorhanden, dann entsperren
.Enabled = .ListCount > 0
'Auf erste Zeile stellen
If .Enabled Then .ListIndex = 0
Else
'Wenn keine Ortsteile vorhanden Combobox leeren und sperren
.Clear
.Enabled = False
End If
End With
'Listindex der PLZ-Combobox auf den Ort einstellen, hier benötigen wir jetzt den Index der Ort-Combobox
cboPLZ.ListIndex = cboOrt
'Hilfsvariable auf Wahr stellen
bolAction = True
End Sub
Private Sub cboPLZ_Change()
Dim lngI As Long
On Error Resume Next
'bolAction ist eine Hilfsvariable um mehrfachaufruf des Codes zu unterbinden
If Not bolAction Then Exit Sub
'bolAction auf Falsch setzen
bolAction = False
With cboTeil
'bolAction auf Falsch setzen
If objADO Is Nothing Then Call initializeADO
'Recordset des ADO-Objectes nach der Ort filtern, hier benötigen wir den Index!
objADO.Filter = "PLZ=" & cboPLZ
If Not objADO.EOF Then
'Combobox für die Ortsteile leeren
.Clear
For lngI = 2 To objADO.Fields.Count - 1
If Not IsNull(objADO.Fields(lngI).Value) Then
'Wenn Ortsteile vorhanden, dann in Combobox schreiben
.AddItem objADO.Fields(lngI).Value
End If
Next
'Wenn Einträge vorhanden, dann entsperren
.Enabled = .ListCount > 0
'Auf erste Zeile stellen
If .Enabled Then .ListIndex = 0
Else
'Wenn keine Ortsteile vorhanden Combobox leeren und sperren
.Clear
.Enabled = False
End If
End With
'Value der Ort-Combobox auf den Ort einstellen, Value in Ort = Listindex in PLZ
cboOrt = cboPLZ.ListIndex
'Hilfsvariable auf Wahr stellen
bolAction = True
End Sub
Private Sub UserForm_Initialize()
Dim varList() As Variant, lngI As Long
On Error Resume Next
'Um nicht bei jeder Änderung in den Comboboxen die Daten neu einlesen zu müssen
'werden die Daten beim Aufruf des UF geladen.
Call initializeADO
'Zum ersten Datensatz wechseln
objADO.moveFirst
'Array für die Orte dimensionieren
Redim varList(objADO.RecordCount - 1)
'Datensätze durchaufen
Do Until objADO.EOF
'Die PLZ sind in der Tabelle schon sortiert, daher können wir sie direkt einlesen
cboPLZ.AddItem objADO.Fields("PLZ")
'Die Orte werden in das Array gelesen und mit einem Index versehen, diesen brauchen wir
'um später auf den richtigen Eintrag zugreifen zu können.
varList(lngI) = objADO.Fields("Ort") & "_" & CStr(lngI)
'Index inkrementieren
lngI = lngI + 1
'Zum nächsten Datensatz wechseln
objADO.moveNext
Loop
'Array sortieren
Call QuickSort(varList)
With cboOrt
'cboOrt hat zwei Spalten, die Erste enthält den Index, die zweite den Ort
'In den Eigenschaften ist die Spaltenbreite der ersten Spalte auf 0 gestellt,
'damit sie nicht angezeigt wird. Ebenfals in den Eigenschaften ist TextColumn auf 2 gestellt
'damit der Text der zweiten Spalte angezeigt wird.
'Array duchlaufen und Einträge der Combobox zuweisen
For lngI = 0 To UBound(varList)
'Index
.AddItem Split(varList(lngI), "_")(1)
'Ort
.List(.ListCount - 1, 1) = Split(varList(lngI), "_")(0)
Next
End With
cboTeil.Enabled = False
bolAction = True
End Sub
Private Sub UserForm_Terminate()
Set objADO = Nothing
End Sub
'Routine zum sortieren der Ortschaften
Private Sub QuickSort(data() As Variant, Optional UG, Optional OG)
Dim P1 As Long, P2 As Long, T1 As Variant, T2 As Variant
UG = IIf(IsMissing(UG), LBound(data), UG)
OG = IIf(IsMissing(OG), UBound(data), OG)
P1 = UG
P2 = OG
T1 = data((P1 + P2) / 2)
Do
Do While (data(P1) < T1): P1 = P1 + 1: Loop
Do While (data(P2) > T1): P2 = P2 - 1: Loop
If P1 <= P2 Then
T2 = data(P1): data(P1) = data(P2): data(P2) = T2
P1 = P1 + 1: P2 = P2 - 1
End If
Loop Until (P1 > P2)
If UG < P2 Then QuickSort data, UG, P2
If P1 < OG Then QuickSort data, P1, OG
End Sub