Nedtælling i excel

Vis lige koden her

Det er en længere kode, da er forskellige ting, men her er hele koden.

Sub FindToday()
' funktion der finder aktuelle dato og evt. kolonnen med brugerens initialer
' VBA-code created 2007 by Folmer Jensen, folj@novonordisk.com (privat: folmer@vindehelsinge.dk)

Dim objWSH As Object
Dim Fcol As Integer
Const InitRow As Integer = 8 ' konstant for hvilken række initialer befinder sig i
Const AntalInits As Integer = 500 ' konstant for max. antal initialer (medarbejdere) der er i planen

' henter initialer der blev logget på windows med
  Set objWSH = CreateObject("WScript.Network")
  LoginUserString = objWSH.UserName

' vælger det rigtige ark
  Sheets("Vagtplan ").Select
 
End Sub

' FCol har default-value 3
  Fcol = 3

' løber arrayet 'Id' igennem og sammenligner
  For i = 1 To AntalInits
    If Cells(InitRow, i).Value = UCase(LoginUserString) Then
      Fcol = i
      Exit For
    End If
  Next i
 
' FRow skal finde aktuel dato
  FRow = FindRow(Date)

  Cells(FRow, Fcol).Select

End Sub

Function FindRow(SearchValue)
' funktion der bruges i forbindelse med FindToday
' VBA-code created 2007 by Folmer Jensen, folj@novonordisk.com (privat: folmer@vindehelsinge.dk)

Const DatoCol As Integer = 3 ' konstant for hvilken kolonne datoer befinder sig i
Dim i As Integer
    For i = 1 To 2000
        If Cells(i, DatoCol).Value = SearchValue Then
            FindRow = i
            i = 2000
        End If
    Next i
End Function

Sub insert_comment()
' funktion der indsætter kommentar og formaterer initialer og dato i kommentaren
' VBA-code created 2007 by Folmer Jensen, folj@novonordisk.com (privat: folmer@vindehelsinge.dk)

' henter initialer der blev logget på windows med
  Set objWSH = CreateObject("WScript.Network")
  LoginUserString = objWSH.UserName
 
' måler antal tegn i initialer
  LoginUserStringLength = Len(LoginUserString)

  ActiveCell.NoteText Nu ' Nu er default ingenting, så evt. gammel kommentar fjernes

' henter data til kommentar
    ActiveCell.AddComment
    ActiveCell.Comment.Visible = False
    InsertInit = UCase(LoginUserString)
    Nu = Date
    Inserttext = InputBox("Tekst til kommentar...", "Indtast kommentartekst")

' indsætter kommentar
    ActiveCell.Comment.Text Text:=InsertInit & ": " & Nu & " " & Chr(10) & Inserttext

' formaterer initialer i kommentar
  With ActiveCell.Comment.Shape.TextFrame.Characters(Start:=1, Length:=LoginUserStringLength + 1).Font
  .Name = "Arial"
  .Size = 10
  .Bold = True
  End With
 
' formaterer resten af kommentar
  With ActiveCell.Comment.Shape.TextFrame.Characters(Start:=LoginUserStringLength + 2).Font
  .Name = "Arial"
  .Size = 10
  End With
End Sub

Sub MakeBackUp()
' funktion der indsætter tager en daglig backup til defineret mappe
' VBA-code created 2007 by Folmer Jensen, folj@novonordisk.com (privat: folmer@vindehelsinge.dk)

Dim StdMappe As String
Dim BackupMappe As String
Dim BackupFilnavn As String
StdMappe = "\\fsdkba100\000-0034\Produktion\Detemir\Operatør PIA IV\undermappe friplan" ' sti til mappen hvor den rigtige plan ligger
BackupMappe = StdMappe & "\kopi af vagtplan\søjleproces\" ' sti til mappen hvor back-ups af plan ligger
BackupFilnavn = "AutoKopi_" & Format(Now - 1, "YYYYMMDD") & ".xls" ' vi generer et filnavn til backup

If Right(ThisWorkbook.Path, 34) = Right(StdMappe, 34) Then ' vi skal lige sikre os at funktionen kun foretages af den rigtige friplan, og ikke fra backups
  If Dir(BackupMappe & BackupFilnavn) = "" Then ' hvis ikke backup fra i dag findes i forvejen
  ActiveWorkbook.SaveCopyAs BackupMappe & BackupFilnavn ' vi laver en SaveCopyAs
  EraseBackUp ' og vi tjekker om der findes gamle backups der skal slettes
  End If
Else
'MsgBox "Backup oprettes ikke fra denne sti..." ' brugt til test
End If

End Sub

Sub EraseBackUp()
' funktionen der sletter eventuelle gamle backups
' VBA-code created 2007 by Folmer Jensen, folj@novonordisk.com (privat: folmer@vindehelsinge.dk)

Dim i As Integer
Dim Offset As Integer
Dim BackupMappe As String
Const EraseOlderThan As Integer = 30 'konstant for hvor mange dage gamle backups skal gemmes

BackupMappe = "\\fsdkba100\000-0034\Produktion\Detemir\Operatør PIA IV\undermappe friplan" ' sti til mappen hvor back-ups af plan ligger

    For i = 0 To 30 ' vi søger efter op til 30 gamle backups
    Offset = EraseOlderThan + i
    SletBackupFilnavn = "AutoKopi_" & Format(Now - Offset, "YYYYMMDD") & ".xls"
'    MsgBox "Filen " & BackupMappe & SletBackupFilnavn & " testes" ' brugt til test
    If Dir(BackupMappe & SletBackupFilnavn) <> "" Then
        Kill (BackupMappe & SletBackupFilnavn)
'        MsgBox "Filen " & BackupMappe & SletBackupFilnavn & " slettet" ' brugt til test
    End If
    Next
End Sub

Sub test_slet() ' funktion der kan bruges til test af EraseBackUp
Dim BackupMappe As String

BackupMappe = "\\fsdkba100\000-0034\Produktion\Detemir\Operatør PIA IV\undermappe friplan" ' sti til mappen hvor back-ups af plan ligger

  EraseBackUp
End Sub
Sub SetTime()
DownTime = Now + TimeValue("00:20:00")
Application.OnTime DownTime, "ShutDown"
End Sub

Sub ShutDown()


ThisWorkbook.Close SaveChanges:=True