Const startRæk = 6
Const slutRæk = 22
Const startKol = 6
Dim medicinRækker As Variant
Dim ugeArk As Worksheet, ugeNr As Byte
Dim dgNavn As Variant
Dim dagNr As Byte
Private Sub worksheet_activate()
Dim ræk As Byte, ugeRæk As Byte, ix As Byte
medicinRækker = Array(7, 19, 31, 44, 57, 70, 83, 96, 109)
dgNavn = Array("", "Man", "Tir", "Ons", "Tor", "Fre", "Lør", "Søn")
dagNr = hentDagensNr(Date)
ugeNr = beregnUgeNr(Date)
Range("D2") = ugeNr
Range("D3") = hentDagensNavn(dagNr)
Range("D4") = Date
Set ugeArk = ActiveWorkbook.Sheets(CStr(ugeNr))
ix = 0
Rem Overfør medicinNavne fra aktuelle ugeark
For ræk = startRæk To slutRæk Step 2
ugeRæk = medicinRækker(ix)
Range("C" & ræk) = ugeArk.Range("D" & ugeRæk)
ix = ix + 1
Next ræk
Rem overfør evt. dosis (vol) til aktuelle datolinje pr. præparat
hentDosisFraUgeArk
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ræk As Byte, kol As Byte, svar As Byte
ræk = Target.Row
kol = Target.Column
If ræk = 3 Then
If kol >= 5 And kol <= 13 Then
svar = MsgBox("Opdater kl.: " & CStr(Cells(ræk, kol)) & "?", vbYesNo, "Medicinudlevering")
If svar = 6 Then
opdaterUgeArk kol
End If
End If
End If
End Sub
Sub hentDosisFraUgeArk()
Dim kol As Byte, ini As String, vol As String
Dim iRæk As Byte, iKol As Byte, ix As Byte
iRæk = startRæk
iKol = startKol
For ix = 0 To UBound(medicinRækker)
For kol = 4 To 12 Step 2
vol = ugeArk.Cells(medicinRækker(ix) + 3 + dagNr, kol)
If vol <> "" Then
Cells(iRæk, iKol) = vol
End If
iKol = iKol + 2
Next kol
iRæk = iRæk + 2
iKol = startKol
Next ix
End Sub
Sub opdaterUgeArk(kol As Byte)
Dim ini As String, vol As String
Dim ræk As Byte, ugeRæk As Byte, ix As Byte
ix = 0
For ræk = startRæk To slutRæk Step 2
ugeRæk = medicinRækker(ix) + 3 + dagNr
ini = Cells(ræk, kol)
vol = Cells(ræk, kol + 1)
Rem Indsætter kun på ugeark, hvis ini + vol er udfyldt
If ini <> "" And vol <> "" Then
ugeArk.Cells(ugeRæk, kol - 2) = ini
ugeArk.Cells(ugeRæk, kol - 1) = vol
End If
ix = ix + 1
Next ræk
End Sub
Private Function beregnUgeNr(dato)
Dim dag1 As Date, denFørsteUgedag, ugeNr, årx, dagx As Date
dag1 = dato
denFørsteUgedag = Format(dag1, "w", 2, 2)
ugeNr = Format(dag1, "ww", 2, 2)
Rem ryk frem til uge 1 - hvis den 1. uge ikke er 1
If ugeNr <> "1" Then
While Format(dag1, "ww", 2, 2) <> "1"
dag1 = DateAdd("d", 1, dag1)
Wend
Else
If denFørsteUgedag <> 1 Then
dag1 = DateAdd("d", (Val(denFørsteUgedag) - 1) * -1, dag1)
End If
End If
If uge <> "1" Then
dag1 = DateAdd("ww", Val(uge) - 1, dag1)
End If
beregnUgeNr = ugeNr
End Function
Public Function hentDagensNr(dato As Date)
hentDagensNr = Weekday(dato, vbMonday)
End Function
Private Function hentDagensNavn(dagsnr As Byte)
hentDagensNavn = dgNavn(dagsnr)
End Function
