hjælp til vba

Ja - send evt. filen(erne) eller en "model" af opbygningen til pb@supertekst-it.dk

Kode i Userform:
================
Private Sub CommandButton1_Click()              'OK
Dim cc As Control
    If Me.ugenr <> "" And IsNumeric(Me.ugenr) = True Then
        For Each cc In Me.Controls
            If InStr(LCase(cc.Name), "optionbutton") = 1 Then
                If cc.Value = True Then
                    ThisWorkbook.ugeDag = LCase(cc.Caption)
                    ThisWorkbook.ugenr = Me.ugenr
                    Unload UserForm1
                    Exit Sub
                End If
            End If
        Next
        ThisWorkbook.ugeDag = ""
    Else
        MsgBox ("Ugenr ikke angivet eller ikke numerisk")
    End If
End Sub
Private Sub CommandButton2_Click()              'Annuller
    Unload UserForm1
End Sub


Kode i Ark1:
============
Const stiRotation = "C:\Documents and Settings\pb\Skrivebord\0303Rotation"      'TILPASSES
Dim dd As Date, rXLS As Object
Dim xSti
Public Sub startFejlListe()
Rem Beregner dato på basis af Ugenr+ugedag
    dd = findDatoUge(ThisWorkbook.ugenr, ThisWorkbook.ugeDag)
     
    åbnRotationsPlan
    testDagensFejl dd
   
Rem luk Rotationsplan
    rXLS.Application.DisplayAlerts = False
    rXLS.Quit
    Set rXLS = Nothing
   
    MsgBox ("FejlListe testet")
End Sub
Private Sub åbnRotationsPlan()
    Set rXLS = CreateObject("excel.application")
    With rXLS
        .Workbooks.Open (stiRotation + "\uge " + ThisWorkbook.ugenr + "\" + ThisWorkbook.ugeDag + ".xls")
        .ActiveWorkbook.Sheets(1).Activate
    End With
End Sub
Private Sub testDagensFejl(dato)
Dim antalRæk, ræk, testDato, person
    testDato = Format(dato, "dd-mm-yy")
   
    antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
   
    For ræk = 2 To antalRæk
Rem Test om fejl opstod på dato
        afkast = Cells(ræk, 2)
        afkastcelle = Cells(ræk, 3)
        afkastdato = Format(afkastcelle, "dd-mm-yy")
        afkasttid = Format(afkastcelle, "hh:mm")
        If afkastdato = testDato Or efterMidnat(afkastdato, afkasttid, testDato) = True Then
            fejlid = findDataFraRotation(afkast, afkasttid)
            If fejlid <> "" Then
                person = findPerson(fejlid, afkasttid)
                Cells(ræk, 7) = person
            End If
        End If
    Next ræk
End Sub
Private Function efterMidnat(afkDato, afkTid, tDato)                'test om "næste dag" i tiden 00:00 - 01:30
Dim tid1 As Date, tid2 As Date, nxtDato
    tid1 = "00:00"
    tid2 = "01:30"
    nxtDato = Format(DateAdd("d", 1, tDato), "dd-mm-yy")
   
    If nxtDato = afkDato And afkTid >= tid1 And afkTid <= tid2 Then
        efterMidnat = True
    Else
        efterMidnat = False
    End If
End Function
Private Function findDataFraRotation(afk, tid)
Dim sNr
    With rXLS
        findDataFraRotation = findSnr(afk)
    End With
End Function
Private Function findSnr(afk)
    With rXLS
        For ræk = 2 To 5
            For kol = 10 To 15
                If .Cells(ræk, kol) = afk Then
                    findSnr = Left(.Cells(ræk, 9), Len(.Cells(ræk, 9)) - 1) ': fjernes
                    Exit Function
                End If
            Next kol
        Next ræk
    End With
   
Rem Afkastnr Ikke fundet
    findSnr = ""
End Function
Private Function findPerson(fejl, tid)
Dim kol, fraKl As Date, tilKl As Date, t As Date
    t = tid
    With rXLS
        For kol = 4 To 24
            fraKl = .Cells(6, kol)
            tilKl = DateAdd("n", 30, fraKl)
            If t >= fraKl And t <= tilKl Then
                Exit For
            End If
        Next kol
   
        For ræk = 6 To 20
            If .Cells(ræk, kol) = fejl Then
                findPerson = .Cells(ræk, 3)
                Exit Function
            End If
        Next ræk
    End With
    findPerson = "???"
End Function
Private Function findDatoUge(unr, dag)                  'første dato med ugenr
Dim dato, ugenr
    ugenr = 0
    dato = Format("01-01-" + CStr(Year(Now)), "dd-mm-yy")
    ugenr = Format(dato, "ww", 2, 2)
   
    While ugenr = 52
        ugenr = Format(dato, "ww", 2, 2)
        dato = DateAdd("d", 1, dato)
    Wend
   
    While ugenr <> unr
        ugenr = Format(dato, "ww", 2, 2)
       
        If ugenr = unr Then
            dnr = dagIugen(dag)
            findDatoUge = DateAdd("d", dnr, dato)
            Exit Function
        End If
        dato = DateAdd("d", 1, dato)
    Wend
    findDatoUge = ""
End Function
Private Function dagIugen(dag)
Dim dage As Variant
    dage = Array("mandag", "tirsdag", "onsdag", "torsdag", "fredag")
    For d = 0 To 4
        If dage(d) = dag Then
            dagIugen = d
            Exit Function
        End If
    Next d
End Function