Was stimmt in diesem Code nicht?

[Windlaeufer]

Hallo zusammen,
ich bräuchte mal eure Hilfe,
wer sieht in diesem Code den Fehler,
es werden alle Kriterien zusammen gestellt, aber an oRs wird nichts übergeben.

Code:

Private Sub cboKundenSuchen_Click()
On Error GoTo Err_cboKundenSuchen_Click
'  Erstelle eine WHERE-Klausel, unter Verwendung der Suchkriterien,
'  die der Benutzer eingegeben hat, und stelle die Eigenschaft "Datenherkunft"
'  der MSFlex und der MSGrid Elemente" ein.
Screen.MousePointer = vbHourglass   'Mauszeiger verändern
'####
Dim oCN As Object
Dim oRS As Object
Dim sCS As String
Dim sPfad As String
Set oCN = CreateObject("ADODB.Connection")
Set oRS = CreateObject("ADODB.Recordset")
sPfad = ActiveWorkbook.FullName
''''für xlsx-Dateien
'''sCS = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sPfad & _
'''  ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
'für xlsm-Dateien
sCS = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sPfad & _
  ";Extended Properties=""Excel 12.0 Macro;HDR=YES"";"
'####
Dim MySQL As String, MyCriteria As String, MyRecordSource As String
Dim ArgCount As Integer
Dim intCounter As Integer
Dim tmp As Variant
Dim strQuery As String
'  Initialisiere die Argumentenzahl.
ArgCount = 0
'  Initialisiere die SELECT-Anweisung.
MySQL = "Select [Datum],[KW],[Jahr],[Monat],[Tonnage_1Schicht],[Mitarbeiter_1Schicht] From [Data$]WHERE "
MyCriteria = ""
'  Verwenden der in die Textfelder im Formularkopf eingegebenen Werte,
'  zum Erstellen von Kriterien für die WHERE-Klausel.
AddToWhere [SuchKW], "[KW]", MyCriteria, ArgCount
AddToWhere [SuchMonat], "[Monat]", MyCriteria, ArgCount
AddToWhere [SuchMitarbeiter], "[Mitarbeiter_1Schicht]", MyCriteria, ArgCount
'  Falls kein Kriterium spezifiziert wurde, gebe alle Datensätze zurück.
If MyCriteria = "" Then
MyCriteria = "True"
End If
'Erstelle die SELECT-Anweisung.
MyRecordSource = MySQL & MyCriteria

'###### hier vermute ich den Fehler, finde in aber nicht ############

oCN.Open sCS
oRS.Source = MyRecordSource
oRS.ActiveConnection = oCN
oRS.Open

'###########################################
Worksheets("Ergebnis").Activate
       ActiveSheet.Cells.ClearContents
        ActiveSheet.Range("A2").CopyFromRecordset oRS
        Kopfzeile oRS
'ActiveSheet.Range("A2").CopyFromRecordset oRS
 
oRS.Close
oCN.Close
Set oRS = Nothing
Set oCN = Nothing
Screen.MousePointer = vbDefault
Exit_cboKundenSuchen_Click:
Exit Sub
Err_cboKundenSuchen_Click:
'Fehler abfangen, wenn kein Kriterium ausgewählt wurde
'MsgBox "Achtung: Sie müssen mindestens ein Kriterium eingeben!", 48, "Sie haben etwas vergessen"
Resume Next
End Sub

[Steffl]

Hallo,

hast du es schon mal im Einzelschrittmodus durchlaufen lassen?

[LCohen]

Fehlen in der sCS-Zuweisung evtl. weitere Gänsefüßchen?

[Windlaeufer]

Code:

Option Explicit
Private Sub AddToWhere(FieldValue As Variant, FieldName As String, MyCriteria As String, ArgCount As Integer)
On Error GoTo Err_AddToWhere
'  Erstelle Kriterien für die WHERE-Klausel.
If FieldValue <> "" Then
'  Füge "Und" hinzu, falls andere Kriterien vorhanden sind.
If ArgCount > 0 Then
MyCriteria = MyCriteria & " And "
End If

'  Anhängen des Kriteriums an existierende Kriterien.
'  Schließe "FieldValue" und "Sternchen" in Anführungszeichen und bei Excel in % Zeichen ein.
MyCriteria = (MyCriteria & FieldName & " Like " & Chr(39) & Chr(37) & FieldValue & Chr(37) & Chr(39))
''%uwe%'
'  Inkrementiere die Zahl der Argumente.
ArgCount = ArgCount + 1
End If
Exit_AddToWhere:
Exit Sub

Err_AddToWhere:
'Fehler abfangen,wenn kein Kriterium ausgewählt wurde
MsgBox "Achtung: Sie müssen mindestens ein Kriterium eingeben!", 48, "Sie haben etwas vergessen"
Resume Next

End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub

Private Sub cboKundenSuchen_Click()
On Error GoTo Err_cboKundenSuchen_Click
'  Erstelle eine WHERE-Klausel, unter Verwendung der Suchkriterien,
'  die der Benutzer eingegeben hat, und stelle die Eigenschaft "Datenherkunft"
'  der MSFlex und der MSGrid Elemente" ein.
Dim i As Long
Dim oCN As Object
Dim oRS As Object
Dim sCS As String
Dim sPfad As String
Set oCN = CreateObject("ADODB.Connection")
Set oRS = CreateObject("ADODB.Recordset")
sPfad = ActiveWorkbook.FullName

''''für xlsx-Dateien
'''sCS = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sPfad & _
'''  ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

'für xlsm-Dateien
sCS = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sPfad & _
 ";Extended Properties=""Excel 12.0 Macro;HDR=YES"";"
'####

Dim MySQL As String, MyCriteria As String, MyRecordSource As String
Dim ArgCount As Integer

'  Initialisiere die Argumentenzahl.
ArgCount = 0
'  Initialisiere die SELECT-Anweisung.
MySQL = "Select [Datum],[KW],[Jahr],[Monat],[Prod_Std_1Schicht],[Anzahl_Pakete_1Schicht],[Prod_Länge_1Schicht],[Tonnage_1Schicht],[Produkt_1Schicht],[Mitarbeiter_1Schicht] From [Data$] Where"
MyCriteria = ""     'lösche zuerst die Variablen
'  Verwenden der in die Textfelder im Formularkopf eingegebenen Werte,
'  zum Erstellen von Kriterien für die WHERE-Klausel.
AddToWhere [SuchDatum], "[Datum]", MyCriteria, ArgCount
AddToWhere [SuchKW], "[KW]", MyCriteria, ArgCount
AddToWhere [SuchJahr], "[Jahr]", MyCriteria, ArgCount
AddToWhere [SuchMonat], "[Monat]", MyCriteria, ArgCount
AddToWhere [SuchProdukt], "[Produkt_1Schicht]", MyCriteria, ArgCount
AddToWhere [SuchMitarbeiter], "[Mitarbeiter_1Schicht]", MyCriteria, ArgCount

'  Falls kein Kriterium spezifiziert wurde, gebe alle Datensätze zurück.
If MyCriteria = "" Then
MyCriteria = "True"
End If
'Erstelle die SELECT-Anweisung.
MyRecordSource = MySQL & MyCriteria

oCN.Open sCS
With oRS
   .ActiveConnection = oCN
   .Source = MyRecordSource
   .Open
End With
Worksheets("Ergebnis").Activate
      ActiveSheet.Cells.ClearContents
       ActiveSheet.Range("A6").CopyFromRecordset oRS
       Kopfzeile oRS

oRS.Close               'Verbindungen wieder schließen
oCN.Close
Set oRS = Nothing
Set oCN = Nothing

Unload frmSuchen        'Formular wieder schließen

Exit_cboKundenSuchen_Click:
Exit Sub
Err_cboKundenSuchen_Click:
'Fehler abfangen, wenn kein Kriterium ausgewählt wurde
'MsgBox "Achtung: Sie müssen mindestens ein Kriterium eingeben!", 48, "Sie haben etwas vergessen"
Resume Next
End Sub

Sub Kopfzeile(ByRef oRS As Object)
Dim iFelder As Integer
For iFelder = 0 To oRS.Fields.Count - 1
 With ActiveSheet.Range("A5").Offset(0, iFelder)
   .Value = oRS.Fields(iFelder).Name
''''    .Font.Bold = True
''''    .Interior.ColorIndex = 15
''''    .HorizontalAlignment = xlCenter
''''    With .Borders(xlEdgeLeft)
''''        .LineStyle = xlContinuous
''''        .Weight = xlThin
''''        .ColorIndex = xlAutomatic
''''    End With
''''    With .Borders(xlEdgeTop)
''''        .LineStyle = xlContinuous
''''        .Weight = xlThin
''''        .ColorIndex = xlAutomatic
''''    End With
''''    With .Borders(xlEdgeBottom)
''''        .LineStyle = xlContinuous
''''        .Weight = xlThin
''''        .ColorIndex = xlAutomatic
''''    End With
''''    With .Borders(xlEdgeRight)
''''        .LineStyle = xlContinuous
''''        .Weight = xlThin
''''        .ColorIndex = xlAutomatic
''''    End With
 End With
Next 'iFelder

Hallo LCohen ,Hallo Steffl

danke für eure Hinweise, ich habe den Fehler gefunden, er lag in den fehlenden Prozentzeichen in der Like Anweisung (Chr37)