Avatar billede hbei Nybegynder
08. januar 2016 - 09:40 Der er 2 kommentarer

Nedtælling i excel

Jeg har et excel ark, hvor det lukker ned efter 20 minutter, jeg kunne godt tænke mig at F.eks A1 var en funktion som talte ned, så man kunne se hvornår arket lukkede, næste gang man åbner arket, skal det igen tælle ned fra 20 min, og ikke fra hvor langt man har noget.

mvh
Henning
Avatar billede finb Ekspert
08. januar 2016 - 14:44 #1
Vis lige koden her
Avatar billede hbei Nybegynder
08. januar 2016 - 16:42 #2
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
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Kurser inden for grundlæggende programmering

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester