Hjælp til at rette indeholde af vba-koder
HejJeg har følgende vba koder, som jeg gerne skulle have rette til:
Const stiRotation = "C:\Users\Inger\Desktop\Team Fredericia\Rotationsplaner"
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")
Rem Test om fejl-tidspunktligger i "eksklusiv-zoner
If testEksklusivZoner(afkasttid) = False Then
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
End If
Next ræk
End Sub
Private Function testEksklusivZoner(tidsp)
Dim x1St As Date, x1Sl As Date, x2St As Date, x2Sl As Date
x1St = "19:00"
x1Sl = "19:02"
x2St = "19:30"
x2Sl = "19:32"
If tidsp >= x1St And tidsp <= x1Sl Or tidsp >= x2St And tidsp <= x2Sl Then
testEksklusivZoner = True
Else
testEksklusivZoner = False
End If
End Function
Private Function efterMidnat(afkDato, afkTid, tDato) 'test om "næste dag" i tiden 00:00 - 01:30
Dim tid1 As Date, tid2 As Date, tid3 As Date, tid4 As Date, nxtDato
tid1 = "00:00"
tid2 = "00:30"
tid3 = "01:15"
tid4 = "01:45"
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
Jeg har følgende problem:
Da mine 18:00 vagter skulle begynde at møde 18:15 og mine 18:30 vagter skulle møde 18:45 begyndte koden, at ikke kunne finde fejlen fra 18:15 – 19: 00 og fra 01:00 – 01:45, da skifte er blevet lavet om i disse tidspunkter, så vi skifter fra 18:15 – 18:45, 18:45 – 19:00, 00:30 – 01:15 og 01:15 – 01:45. Er der nogle der kan hjælpe mig med at rette koden til, så den kan finde fejlene i disse tidspunkter.
