Attribute VB_Name = "Modul14"
Public ez As Long, med1, med2
Option Compare Text

Sub us_kra()
    Dim pfad As String, startdatum As String
    pfad = Sheets("Tabelle1").Cells(2, 4).Value
    startdatum = Sheets("Tabelle1").Cells(4, 4).Value
    Sheets("us_kra").Select
    Cells.Delete Shift:=xlUp
    Range("A1").Select
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "ODBC;DSN=dBASE Files;DefaultDir=" & pfad & ";DriverId=533;MaxBufferSize=2048;PageTimeout=5;" _
        , Destination:=Range("$A$1")).QueryTable
        'Zeilenlänge <= 255 Zeichen
        .CommandText = Array( _
        "SELECT TRIM(krank.OHR), BESTAND.GEBURT, BESTAND.GESCHLECHT, krank.LAKTATION, krank.DATUM, krank.ART, krank.DIAGNOSE, krank.STAUFEN, Wahl.TXT, krank.MEDIKAMENT, krank.EINHEIT, krank.DOSIS, krank.VERABREICH, krank.BEHANDLUNG, krank.KOMMENTAR ", _
        "FROM BESTAND.DBF BESTAND, krank.DBF krank, Wahl.DBF Wahl ", _
        "WHERE BESTAND.OHR = krank.OHR AND Wahl.NUM = krank.DIAGNOSE AND (krank.DATUM>={d '" & startdatum & "'}) AND (krank.DIAGNOSE Is Not Null) AND (krank.MEDIKAMENT Is Not Null) ", _
        "AND ((krank.ART IN ('BW','EU','ZH','SE','KK','PA','SW','SO','SY') AND (Wahl.SCHL = krank.ART+'DIAG')) OR (krank.ART NOT IN ('BW','EU','ZH','SE','KK','PA','SW','SO','SY') AND (Wahl.SCHL LIKE '%DIAG'))) ", _
        "ORDER BY krank.OHR, krank.MEDIKAMENT, krank.DATUM" _
        )
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = "Tabelle_Abfrage_von_dBASE_Files"
        .Refresh BackgroundQuery:=False
    End With
    ActiveSheet.ListObjects("Tabelle_Abfrage_von_dBASE_Files").Unlist
    Range("B:B,E:E").NumberFormat = "dd/mm/yyyy;@"
    Columns("C:C").TextToColumns Destination:=Range("C1"), DataType:=xlFixedWidth, FieldInfo:=Array(0, 1), TrailingMinusNumbers:=True
    Range("A1").Select
    Cells(1, 1).Value = "OHR"
    Call us_trocken(pfad, startdatum)
    Call us_alter
    Call us_med
    MsgBox "Abfrage fertig", vbInformation
End Sub

Sub us_trocken(pfad As String, startdatum As String)
    Dim i As Long
    Sheets("us_tro").Select
    Cells.Delete Shift:=xlUp
    Range("A1").Select
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "ODBC;DSN=dBASE Files;DefaultDir=" & pfad & ";DriverId=533;MaxBufferSize=2048;PageTimeout=5;" _
        , Destination:=Range("$A$1")).QueryTable
        'Zeilenlänge <= 255 Zeichen
        .CommandText = Array( _
        "SELECT TRIM(krank.OHR), BESTAND.GEBURT, BESTAND.GESCHLECHT, krank.LAKTATION, krank.DATUM, krank.ART, krank.DIAGNOSE, krank.STAUFEN, krank.WB, krank.MEDIKAMENT, krank.EINHEIT, krank.DOSIS, krank.VERABREICH, krank.BEHANDLUNG, krank.KOMMENTAR ", _
        "FROM BESTAND.DBF BESTAND, krank.DBF krank ", _
        "WHERE BESTAND.OHR = krank.OHR AND (krank.DATUM>={d '" & startdatum & "'}) AND (krank.DIAGNOSE Is Null) AND (krank.MEDIKAMENT Is Not Null) ", _
        "ORDER BY krank.OHR, krank.MEDIKAMENT, krank.DATUM" _
        )
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = "Tabelle_Abfrage_von_dBASE_Files"
        .Refresh BackgroundQuery:=False
    End With
    ActiveSheet.ListObjects("Tabelle_Abfrage_von_dBASE_Files").Unlist
    Range("B:B,E:E").NumberFormat = "dd/mm/yyyy;@"
    Columns("C:C").TextToColumns Destination:=Range("C1"), DataType:=xlFixedWidth, FieldInfo:=Array(0, 1), TrailingMinusNumbers:=True
    Range("A1").Select
    Cells(1, 1).Value = "OHR"
    Cells(1, 9).Value = "TXT"
    If Cells(2, 1).Value <> "" Then
        ez = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        For i = 2 To ez
            Cells(i, 9).Value = "TR = Trocken" 'da kein Staufen und keine Diagnose, hier alle mit medikament ohne erstgenanntes
        Next i
        Columns("I:I").EntireColumn.AutoFit
        Range(Cells(2, 1), Cells(ez, 15)).Copy
        Sheets("us_kra").Select
        ez = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        Cells(ez + 1, 1).Select
        ActiveSheet.Paste
    End If
End Sub

Sub us_alter()
    Dim i As Long, alter As Integer, gesch As String * 1, lakta As Byte
    Sheets("us_kra").Select
    ez = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Cells(1, 16).Value = "Alter in d"
    Cells(1, 17).Value = "Altersklasse"
    Cells(1, 18).Value = "Auswerten/Aphlog"
    'schleife bis ende us_kra
    For i = 2 To ez
        alter = Cells(i, 5).Value - Cells(i, 2).Value 'Alter in Tagen
        gesch = Cells(i, 3).Value '1=m, 2=w
        lakta = Cells(i, 4).Value 'Laktation
        ID = ""
        If alter < 0 Then
            MsgBox "Fehler: Alter kleiner 0 in Zeile " & i, vbCritical, "Fehlermeldung"
        ElseIf alter <= 14 Then
            ID = 20                                   'm+w = VAbData 20
        ElseIf alter <= 152 Then
            ID = 21                                   'm+w = VAbData 21
        ElseIf alter <= 365 Then
            If gesch = "2" Then ID = 22               'w = VAbData 22
            If gesch = "1" Then ID = 25               'm = VAbData 25
        Else
            If gesch = "2" And lakta = 0 Then ID = 23 'w>365L0 = VAbData 23
            If lakta > 0 Then ID = 24                 '>365>L0 = VAbData 24
            If gesch = "1" Then ID = 26               'm>365 = VAbData 26
        End If
        If ID = "" Then MsgBox "Fehler: keine Altersklasse ermittelbar in Zeile " & i, vbCritical, "Fehlermeldung"
        Cells(i, 16).Value = alter
        Cells(i, 17).Value = ID
    Next i
End Sub

Sub us_aus()
    Dim i As Long, a As Long, Ohr As String, Art As String * 2, Sta As String, Txt As String, Med As String, Alt As Integer, Aph As String, Hin As String
    anftime = Time
    Sheets("us_kra").Select
    ez = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Application.ScreenUpdating = False
    Application.AddCustomList ListArray:=Array("nein", "Apho")
    With ActiveWorkbook.Worksheets("us_kra").sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A2:A" & ez & ""), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("R2:R" & ez & ""), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:="nein,Apho", DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("J2:J" & ez & ""), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("E2:E" & ez & ""), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A1:R" & ez & "")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    'formatieren
    Sheets("us_aus_übernahme").Select
    Cells.Delete
    Sheets("us_aus").Select
    Cells.Delete
    Cells(1, 1).Value = "Ohrnummer"
    Cells(1, 2).Value = "Datum"
    Cells(1, 3).Value = "Art"
    Cells(1, 4).Value = "Diagnose"
    Cells(1, 5).Value = "Staufen"
    Cells(1, 6).Value = "Txt"
    Cells(1, 7).Value = "Medikament"
    Cells(1, 8).Value = "Einheit"
    Cells(1, 9).Value = "Dosis"
    Cells(1, 10).Value = "Verabreichung"
    Cells(1, 11).Value = "Alter"
    Cells(1, 12).Value = "A-Klasse"
    Cells(1, 13).Value = "Aphlog"
    Cells(1, 14).Value = "Hinweise"
    'schleife bis ende us_kra
    For i = 2 To ez
        Sheets("us_kra").Select
        If Sheets("us_kra").Cells(i, 18).Value = "nein" Then GoTo weiter
        Ohr = Cells(i, 1).Value
        Dat = Cells(i, 5).Value
        Art = Cells(i, 6).Value
        Dia = Cells(i, 7).Value 'G
        Sta = "'" & Cells(i, 8).Value 'damit bei einstelligen Schlüsseln . am Ende erhalten bleibt, ' entfällt in CSV-Datei
        Txt = Cells(i, 9).Value 'I
        Med = Cells(i, 10).Value
        Ein = Cells(i, 11).Value
        Dos = Cells(i, 12).Value
        Ver = Cells(i, 13).Value 'M
        Alt = Cells(i, 16).Value 'P
        Akl = Cells(i, 17).Value
        Aph = Cells(i, 18).Value
        Hin = Cells(i, 15).Value
        Sheets("us_aus").Select
        a = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
        Cells(a, 1).Value = Ohr
        Cells(a, 2).Value = Dat
        Cells(a, 3).Value = Art
        Cells(a, 4).Value = Dia
        Cells(a, 5).Value = Sta
        Cells(a, 6).Value = Txt
        Cells(a, 7).Value = Med
        Cells(a, 8).Value = Ein
        Cells(a, 9).Value = Dos
        Cells(a, 10).Value = Ver
        Cells(a, 11).Value = Alt
        Cells(a, 12).Value = Akl
        Cells(a, 13).Value = Aph
        Cells(a, 14).Value = Hin
weiter:
    Next i
    Sheets("us_aus").Select
    Columns("A:N").EntireColumn.AutoFit
    ActiveSheet.UsedRange.Copy
    Sheets("us_aus_übernahme").Select
    Cells(1, 1).Select
    ActiveSheet.Paste
    Cells(1, 13).Value = "AB-Datensatz-Id für Aphlog"
    Columns("A:N").EntireColumn.AutoFit
    Cells(1, 1).Select
    Application.ScreenUpdating = True
    endetime = Time
    diff = endetime - anftime
    sek = Round(diff, 5) * 100000
    MsgBox "FERTIG nach " & sek & " Sekunden", vbInformation
End Sub

Sub us_med()
    Dim lmed As Integer, a As Integer, b As Integer, e As Integer, lkra As Long, d As Long, altmed As String, neumed As String, medikament As String
    lmed = Sheets("us_med").Cells(Rows.Count, 1).End(xlUp).Row
    lkra = Sheets("us_kra").Cells(Rows.Count, 1).End(xlUp).Row
    'abfrage der Medi-Ersatz-Namen
    Sheets("us_med").Select
    a = MsgBox("Soll die Medikamentenliste erweitert werden?", vbYesNo + vbQuestion, "Medikamentenliste")
    If a = vbYes Then GoTo ersetzen
    'ja
    Application.ScreenUpdating = False
    For b = 2 To lmed
        Sheets("us_med").Select
        'ist mit dem namen ein medi vorhanden, dann bearbeiten
        If Cells(b, 3).Value = "" Then
            GoTo nmed 'kein eintrag in der zeile
        Else 'ersetzen mit
            altmed = Cells(b, 1).Value
            neumed = Cells(b, 3).Value
            Find_Med (altmed) 'suche altmedikament
            If med1 = "" Or med2 = "" Then GoTo nmed 'Medikament steht noch drin aber nicht mehr in kranktabelle
            'filter aktiv
            Sheets("us_kra").Select
            Rows("1:1").Select
            Selection.AutoFilter
            If med1 <> "" Or med2 <> "" Then ActiveSheet.Range("$A$1:$Q$" & med2 & "").AutoFilter Field:=10, Criteria1:=altmed
            Range("A1").Select
            For c = med1 To med2 Step 1
                If Sheets("us_kra").Cells(c, 10).Value = altmed Then Sheets("us_kra").Cells(c, 10).Value = neumed 'setze neumedikament
            Next c
            Selection.AutoFilter
            'filter inaktiv
        End If
nmed:
    Next b
    'namen sind hier schon umgeschlüsselt
    'Kennzeichen setzen
    For d = 2 To lkra
        medikament = Sheets("us_kra").Cells(d, 10).Value
        'ist das medi evtl. NEIN (nicht auswerten) oder JA bei Antiphlogistika
        For e = 2 To lmed
            If Sheets("us_med").Cells(e, 1).Value = medikament Then
                If Sheets("us_med").Cells(e, 2).Value = "n" Or Sheets("us_med").Cells(e, 2).Value = "nein" Then Sheets("us_kra").Cells(d, 18).Value = "nein"
                If Sheets("us_med").Cells(e, 4).Value = "j" Or Sheets("us_med").Cells(e, 4).Value = "ja" Then Sheets("us_kra").Cells(d, 18).Value = "Apho"
                Exit For
            End If
        Next e
    Next d
    Application.ScreenUpdating = True
    If a <> vbYes Then GoTo weiter
    'nein
ersetzen: 'überspringe diesen PART wenn keine neue Medikamentenliste erzeugt werden soll
    Sheets("us_med").Select
    Cells(1, 1).Value = "MEDIKAMENT"
    Sheets("us_kra").Select
    Range(Cells(2, 10), Cells(lkra, 10)).Copy
    Sheets("us_med").Select
    ez = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    Cells(ez + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Columns("A:A").Select
    ez = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    'duplikate finden und entfernen
    ActiveSheet.Range("$A$1:$C$" & ez & "").RemoveDuplicates Columns:=1, Header:=xlYes
    'sortieren
    Columns("A:E").Select
    With ActiveWorkbook.Worksheets("us_med").sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A2:A" & ez & ""), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A1:E" & ez & "")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
    Cells(1, 2).Value = "Auswerten [n/nein]"
    Cells(1, 3).Value = "ersetzen mit"
    Cells(1, 4).Value = "Antiphlogistika [j/ja]"
    Columns("A:D").EntireColumn.AutoFit
    MsgBox "Medikament ausschließen mit 'n' oder 'nein' in Spalte 'Auswerten'." & vbCrLf & vbLf & _
        "Medikamentennamen ersetzen mit Eingabe in Spalte 'ersetzen mit'." & vbCrLf & vbLf & _
        "Medikament als Antiphlogistikum kennzeichnen mit 'j' oder 'ja'.", vbInformation, "Weitere Vorgehensweise"
weiter:
    Sheets("us_kra").Select
    Cells(1, 1).Select
End Sub

Sub Find_Med(altmed As String)
    Dim FindString As String, Rng As Range
    med1 = ""
    med2 = ""
    FindString = altmed
    If Trim(altmed) <> "" Then
        With Sheets("us_kra").Range("J:J")
            Set Rng = .Find(What:=FindString, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
            If Not Rng Is Nothing Then
                Application.Goto Rng, True
                med1 = ActiveCell.Row
            End If
            Set Rng = .Find(What:=FindString, After:=.Cells(1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
            If Not Rng Is Nothing Then
                Application.Goto Rng, True
                med2 = ActiveCell.Row
            End If
        End With
    End If
End Sub