Clever-Excel-Forum

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

Hallo,

hast du es schon mal im Einzelschrittmodus durchlaufen lassen?

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

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)

Windlaeufer

Steffl

LCohen

Windlaeufer