AW: Problem mit OpenRecordset (Array)
18.02.2008 10:01:39
chris
Hallo Luschi...
hilfe es klappt nicht bei mir :((((((((((
Bitte um deine Hilfe.
Wenn Nummern in Spalte A doppelt vorkommen wird einfach der erste eintrag nicht geschrieben und weiter fehler :((
habe hier mal meinen code der das alles machen sollte..
Wäre wirklich super wenn du oder jemand mir helfen kann.
Option Explicit
Public Const Version As String = "_v.01_02_08"
Dim wspDB As Workspace
Dim strConnect As String
Dim conDB As Connection
Dim strSQL As String
Dim rsetTB As Recordset
Dim lRecCnt As Long
Dim cb As Name
Dim zz
Dim strSQL_teil
Dim s
Public Const A_s As Integer = 102 'Daten Spalten IN Excel die von Oracle gefüllt werden. (Allg. Daten START spalte)
Public Const A_e As Integer = 123 'Daten Spalten IN Excel die von Oracle gefüllt werden. (Allg. Daten ENDE spalte)
Public Const U_s As Integer = 126 'Daten Spalten IN Excel die von Oracle gefüllt werden. ( Daten START spalte)
Public Const U_e As Integer = 204 'Daten Spalten IN Excel die von Oracle gefüllt werden. ( Daten ENDE spalte)
Public Const PfadDatenbank = "pfad.xls"
Dim obj_datenbank As Workbook
Sub auto_open() 'holt daten aus K5AAS und spielt nur benötigte Daten in Tabelle
If MsgBox("Oracle update starten ?", vbYesNo) = vbYes Then
Else
Exit Sub
End If
'Prüfen ob Zugriff auf Datenbank ok - wenn nicht Programm abbruch - Datei schliesen
If Dir(PfadDatenbank) = "" Then
MsgBox ("keine Verbindung zur Datenbank vorhanden. "), vbCritical, "warnung - Zugriff"
MsgBox ("Programm wird geschlossen"), vbCritical, "kein Zugriff auf Datenbank"
ThisWorkbook.Close False
End
Else
'Zugriff OK - Datenbank vorhanden
End If
'----- Datenbank vorhanden (Object verbindung erstellen)
Set obj_datenbank = Workbooks.Open(PfadDatenbank, False, , , "passi")
'Datenbank ausblenden wenn sichtbar
If Windows(obj_datenbank.Name).Visible = True Then Windows(obj_datenbank.Name).Visible = False
'Prüfen ob Datenbank erfolgreich geöffnet wurde
If Not obj_datenbank Is Nothing Then
Else
MsgBox ("Fehlerhaftes Passwort für Datenbank" & Chr(10) & "Datenbank konnte nicht geöffnet _
werden - bitte erneut versuchen"), vbCritical, "Fehler beim öffnen - abbruch"
ThisWorkbook.Close False
End If
If Not obj_datenbank Is Nothing Then
Else
MsgBox ("Fehlerhaftes Passwort für Datenbank - bitte erneut versuchen"), vbCritical, "Fehler _
beim öffnen - abbruch"
End
End If
'prüft ob Datenbank aktuelle Version bzw. Programm aktuell (abgleich Version)
If obj_datenbank.Worksheets(1).Name = "daten" & Version Then
'Zugriff ok richtige Version
Else
MsgBox ("Datenbank Fehlerhaft oder Programm nicht aktuell.Bitte wenden Sie sich "), vbCritical, _
"abbruch"
obj_datenbank.Close False
ThisWorkbook.Close False
Exit Sub
End
End If
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
Set wspDB = CreateWorkspace("XXWorkspace", "Excel", "", dbUseODBC)
strConnect = ("ODBC;DSN=BA_ORA;DBQ=K5_ISP.WORLD;UID=username;pwd=passwort")
Set conDB = wspDB.OpenConnection("MyConName", dbDriverNoPrompt, , strConnect)
'vorhandene Werte löschen ..
obj_datenbank.Worksheets("daten" & Version).Range("daten").ClearContents
strSQL_teil = ""
strSQL = ""
'Teil 1 String um Datenbank Einträge auszulesen
For s = A_s To A_e
For Each cb In obj_datenbank.Names
'prüfen ob name in richtigem sheet(sheet(1)
If InStr(1, cb, "daten" & Version) > 0 Then
If obj_datenbank.Worksheets("daten" & Version).Range(cb).Column = s Then
If cb.Name "daten" Then
strSQL_teil = strSQL_teil & cb.Name & ","
Else
End If
Else
End If
End If
Next
Next
'--------- ENDE Teil 1 ---------------
'Teil 2 String um Datenbank Einträge auszulesen
For s = U_s To U_e
For Each cb In obj_datenbank.Names
'prüfen ob name in richtigem sheet(sheet(1)
If InStr(1, cb, "daten" & Version) > 0 Then
If obj_datenbank.Worksheets("daten" & Version).Range(cb).Column = s Then
strSQL_teil = strSQL_teil & cb.Name & ","
Else
End If
End If
Next
Next
'--------- ENDE Teil 2 ---------------
' ------ String Fertig (erstellen) für Datenbankabfrage
strSQL_teil = Left(strSQL_teil, Len(strSQL_teil) - 1)
strSQL = "SELECT AENDSCHEINNR,REGNR," & strSQL_teil & " FROM datenn"
Set rsetTB = conDB.OpenRecordset(strSQL, dbOpenDynamic)
With rsetTB
If .RecordCount > 0 Then
Do While Not .EOF
lRecCnt = lRecCnt + 1
'String löschen
strSQL_teil = ""
strSQL = ""
For zz = 3 To obj_datenbank.Worksheets("daten" & Version).Cells(obj_datenbank.Worksheets("daten" _
& Version).Rows.Count, 1).End(xlUp).Row
If obj_datenbank.Worksheets("daten" & Version).Cells(zz, 1) = .Fields(0) Then
Update zz
Else
End If
Next
.MoveNext
Loop
Else
MsgBox "Es sind keine Datensätze vorhanden!"
End If
.Close
End With
conDB.Close
'Windows(Obj_Datenbank.Name).Close True
Application.ScreenUpdating = True
Application.EnableCancelKey = xlInterrupt
'MsgBox ("Aktualisierte Datenbank wird gespeichert"), vbInformation, "Info ..."
'Application.DisplayAlerts = False
'obj_datenbank.Save
'obj_datenbank.Close
'Application.DisplayAlerts = True
'ThisWorkbook.Close False
End Sub
Sub Update(zeile)
Dim w
'Einfügen der Arrays (Daten) in Excelsheet
'Vorhandene Daten werden nicht belöscht nur überschrieben ...
'Schleife über einzelne einträge im Array (selbe Reihenfolge wie einträge in Tabelle)
For s = A_s To A_e
w = s - 100
obj_datenbank.Worksheets("daten" & Version).Cells(zeile, s) = rsetTB.Fields(w)
Next
For s = U_s To U_e
w = s - 108
obj_datenbank.Worksheets("daten" & Version).Cells(zeile, s) = rsetTB.Fields(w)
Next
End Sub