Indtastningsformular

DU må godt sende filen - @-adresse under min profil..

du må godt sende filen til bjarne-hansen(at)maildotdk

Ribo:  du har mange åbne spørgsmål, som vel bør lukkes ;-)

Hej bjarnehansen tak for tilbudet, men lader lige supertekst kigge på den.

Tak p5 for venlig henstilling til oprydning i gamle spørgsmål:-) er hermed udført!

Velbekomme - håber I finder en løsning, som I deler med os andre videbegærlige... ;-)

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

Hej supertekst

Det virker perfekt!! Tusind tak for hjælpen.

Ribo

Fint & selv tak..