AW: Userform combo und Textboxen abfragen
23.06.2019 20:27:11
Rob
Hallo Richard,
siehe nachfolgender Code für Late Binding:
'Verweis zu Microsoft Data Object 6.1 Library oder Late Binding
' Dim ADODBConnection As New ADODB.Connection
Dim ADODBConnection As Object
' Dim ADODBRecordset As New ADODB.Recordset
Dim ADODBRecordset As Object
Dim sqlQuery As String, ConnectionString As String, FilePath As String
Set ADODBConnection = CreateObject("ADODB.Connection")
Set ADODBRecordset = CreateObject("ADODB.Recordset")
PS: Habe Dir noch einen Errorhandler eingebaut, für den Fall der Fälle. Am besten die ganze Sub mit Copy/Paste in das Modul einfügen:
Option Explicit
Sub FilterNachPLZ()
Application.ScreenUpdating = False
On Error GoTo Errhandler
'Verweis zu Microsoft Data Object 6.1 Library oder Late Binding
' Dim ADODBConnection As New ADODB.Connection
Dim ADODBConnection As Object
' Dim ADODBRecordset As New ADODB.Recordset
Dim ADODBRecordset As Object
Dim sqlQuery As String, ConnectionString As String, FilePath As String
Set ADODBConnection = CreateObject("ADODB.Connection")
Set ADODBRecordset = CreateObject("ADODB.Recordset")
'Nach ADM gefilterte Listbox in das Array Filtered ADM übertragen
Dim FilteredADM()
Dim SizeLst1 As Integer
SizeLst1 = UserForm1.lst1.ListCount - 1
ReDim FilteredADM(0 To SizeLst1, 0 To 5)
FilteredADM() = UserForm1.lst1.List
'Das Hilfsarbeitsblatt für die Datenauslagerung erstellen -> Namen entsprechend ändern
Worksheets.Add(After:=ThisWorkbook.Sheets(Sheets.Count)).Name = "AuslagerungDaten"
With ThisWorkbook.Sheets("AuslagerungDaten")
' .Visible = False
.Range("E1") = "PLZ"
.Range(Cells(2, 1), (Cells(UBound(FilteredADM, 1) + 2, UBound(FilteredADM, 2) + 1))) = _
FilteredADM()
End With
FilePath = ThisWorkbook.FullName
ConnectionString = "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & FilePath & ";HDR=Yes';"
sqlQuery = "Select * from [AuslagerungDaten$] WHERE PLZ BETWEEN " & UserForm1.txtvon.Text & _
" and " & UserForm1.txtbis.Text & ""
ADODBConnection.Open ConnectionString
With ADODBRecordset
.Source = sqlQuery
.ActiveConnection = ADODBConnection
.Open
End With
'Die Suchergebnisse aus dem SQL-Befehl werden hier in Tabelle3 kopiert. Kannst Du _
entsprechend anpassen!
With Sheets("Tabelle3")
.UsedRange.Delete
.Range("A1").CopyFromRecordset ADODBRecordset
'Anschl. die Werte aus Tabelle 3 in die Listbox übertragen
If Not IsEmpty(.Range("A1")) Then
UserForm1.lst1.List = .Range("A1").CurrentRegion.Value
'Anschließend Auslagerungs-Arbeitsblatt wieder löschen
.UsedRange.Delete
Else
MsgBox "Bitte geben Sie einen gültigen PLZ-Bereich von->bis ein!", vbInformation
End If
End With
Sheets("AuslagerungDaten").Delete
Exit Sub
Errhandler:
MsgBox "Fehlerbeschreibung:" & Err.Description, vbExclamation
Sheets("AuslagerungDaten").Delete
End Sub