AW: Vorstellung und Fehlersuche
06.03.2019 12:50:55
Eric
Ah, verstanden.
Ich wollte nur nicht mit der Tür ins Haus fallen.
Option Compare Database
Option Explicit
Sub StapelExcelTeilImport()
' Verweis auf Microsoft DAO setzen
' Ab AC97
' Was hier steht ist ein Kommentar des Autors, also völlig, aber auch völlig wumpe!
Dim sDatei As String
Dim sPfad As String
Dim AktDatei As String
Dim strFehler As String
Dim xlApp As Object ' Excel.Application
Dim rs As DAO.Recordset
Dim oTargetSheet As Object
Dim oSourceBook As Object
Dim s As Long
Dim z As Long
' Application.ScreenUpdating = False 'Das "Flackern" ausstellen
Const ZielTab = "Stammdaten"
sPfad = "C:\Users\demtroee\Desktop\DB Test\Station-GE1 Therapien"
sDatei = Dir(CStr(sPfad & "*.xl*")) 'Alle Excel Dateien
'CurrentDb.Execute "DELETE FROM " & ZielTab (löscht den letzten Eintrag raus)
Set rs = CurrentDb.OpenRecordset(ZielTab)
' Excel vorbereiten
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
End If
MsgBox "hier"
Do While sDatei " "
MsgBox "hierher"
Set oSourceBook = xlApp.Workbooks.Open(sPfad, sDatei, False, True) 'nur lesend öffnen
'Debug.Print AktDatei
' Import
rs.AddNew 'neuen Exceldatensatz
On Error GoTo Fehler
rs!Geschlecht = xlApp.sheets("Assessments").Cells(4, 5) ' D14
rs!Geburtsdatum = xlApp.sheets("Leistungsdoku Therapeuten").Cells(2, 5) ' E2
rs!Aufnahmedatum = xlApp.sheets("Assessments").Cells(7, 3) ' C7
rs!Fall_ID = xlApp.sheets("Leistungsdoku Therapeuten").Cells(4, 2) ' B4
rs!Größe = xlApp.sheets("Assessments").Cells(57, 3) ' C57
rs!Gewicht = xlApp.sheets("Assessments").Cells(58, 3) ' C58
rs!MMST = xlApp.sheets("Assessments").Cells(14, 4) ' D14
rs!GDS_15 = xlApp.sheets("Assessments").Cells(39, 3) ' C39
rs!Dem_Tect = xlApp.sheets("Assessments").Cells(37, 3) ' C37
rs!Uhrentest = xlApp.sheets("Assessments").Cells(36, 3) ' C36
rs!TINETTI_Balance = xlApp.sheets("Assessments").Cells(42, 3) ' C42
rs!TINETTI_Mobilität = xlApp.sheets("Assessments").Cells(43, 3) ' C43
rs!Romberg_Stand = xlApp.sheets("Assessments").Cells(45, 3) ' C45
rs!Semitandemstand = xlApp.sheets("Assessments").Cells(46, 3) ' C46
rs!Tandemstand = xlApp.sheets("Assessments").Cells(47, 3) ' C47
rs!TUG_Aufnahme = xlApp.sheets("Assessments").Cells(48, 3) ' C48
rs!TUG_Entlassung = xlApp.sheets("Assessments").Cells(48, 4) ' D48
rs!Gehgeschwindigkeit = xlApp.sheets("Assessments").Cells(49, 3) ' C49
rs!Schmerzen_in_Ruhe = xlApp.sheets("Assessments").Cells(54, 3) ' C54
rs!Schmerzen_bei_Mobilisation = xlApp.sheets("Assessments").Cells(55, 3) ' C55
rs!GEK_laut_OPS = xlApp.sheets("Assessments").Cells(70, 3) ' C70
rs!Therapieeinheiten_30min = xlApp.sheets("Assessments").Cells(71, 3) ' C71
rs!Aufenthalt_Tage = xlApp.sheets("Analyse").Cells(10, 6) ' F10
rs!BASS_Mobilität = xlApp.sheets("Assessments").Cells(10, 3) ' C10
rs!BASS_Selbstversorgung = xlApp.sheets("Assessments").Cells(14, 3) ' C14
rs!BASS_Kognition = xlApp.sheets("Assessments").Cells(17, 3) ' C17
rs!BASS_Verhalten = xlApp.sheets("Assessments").Cells(20, 3) ' C20
rs!Barthel_Index = xlApp.sheets("Assessments").Cells(23, 3) ' C23
rs!erweiterter_Barthel_Index = xlApp.sheets("Assessments").Cells(25, 3) ' C25
rs.Update
xlApp.ActiveWorkbook.Close
MsgBox "hierauchnoch"
xlApp.Quit
Set xlApp = Nothing
If strFehler "" Then MsgBox Mid(strFehler, 2)
Exit Sub
Fehler:
strFehler = strFehler & vbCrLf & "Fehler " & Err & ": Datei '" & _
AktDatei & "'"
Resume Next
Loop
' Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
'Variablen aufräumen
Set oTargetSheet = Nothing
Set oSourceBook = Nothing
End Sub