Excel timer laver ballade

Option Explicit

Dim NextTick As Date, t As Date, PreviousTimerValue As Date
Dim ws As Worksheet, rCell As Range

Sub StartTime()
Set ws = Sheets("Calculations")
Set rCell = ws.Range("A1")
PreviousTimerValue = rCell.Value
t = Time
Call ExcelStopWatch
End Sub

Private Sub ExcelStopWatch()
rCell.Value = rCell.Value + TimeValue("00:00:01")
NextTick = Now + TimeValue("00:00:01")

Application.OnTime NextTick, "ExcelStopWatch"
End Sub

Sub StopClock()
On Error Resume Next
Application.OnTime earliesttime:=NextTick, procedure:="ExcelStopWatch", schedule:=False
End Sub

Sub Reset()
On Error Resume Next


Application.OnTime earliesttime:=NextTick, procedure:="ExcelStopWatch", schedule:=False
rCell.Value = 0
End Sub

Option Explicit

Dim NextTick As Date, PreviousTimerValue As Date
Dim NextTick2 As Date, PreviousTimerValue2 As Date
Dim ws As Worksheet, rCell As Range, rCell2 As Range

Sub StartTime()
Set ws = Sheets("Calculations")
Set rCell = ws.Range("A1")
PreviousTimerValue = rCell.Value
Call ExcelStopWatch
End Sub

Private Sub ExcelStopWatch()
rCell.Value = rCell.Value + TimeValue("00:00:01")
NextTick = Now + TimeValue("00:00:01")

Application.OnTime NextTick, "ExcelStopWatch"
End Sub

Sub StopClock()
On Error Resume Next
Application.OnTime earliesttime:=NextTick, procedure:="ExcelStopWatch", schedule:=False
End Sub

Sub Reset()
On Error Resume Next


Application.OnTime earliesttime:=NextTick, procedure:="ExcelStopWatch", schedule:=False
rCell.Value = 0
End Sub
'------Nedtælling----------
Sub StartTimedown()
Set ws = Sheets("Calculations")
Set rCell2 = ws.Range("A2") '-----------Cellen den skal tælle ned i
If rCell2 = "" Then rCell2 = TimeValue("01:00:00")
PreviousTimerValue2 = rCell2.Value
Call ExcelStopWatchDown
End Sub

Private Sub ExcelStopWatchDown()
With rCell2
    .Value = .Value - TimeValue("00:00:01")
    If .Value < TimeValue("00:01:00") Then ' maler baggrunden rød det sidste minut
        .Interior.ColorIndex = 3
    Else
        .Interior.ColorIndex = 0
    End If
End With
NextTick = Now + TimeValue("00:00:01")
Application.OnTime NextTick, "ExcelStopWatchDown"
End Sub

Sub StopClockDown()
On Error Resume Next
Application.OnTime earliesttime:=NextTick, procedure:="ExcelStopWatchDown", schedule:=False
End Sub

Sub ResetDown()
On Error Resume Next


Application.OnTime earliesttime:=NextTick, procedure:="ExcelStopWatchDown", schedule:=False
rCell2.Value = TimeValue("01:00:00")
End Sub

Option Explicit

Dim NextTick As Date, PreviousTimerValue As Date
Dim NextTick2 As Date, PreviousTimerValue2 As Date
Dim ws As Worksheet, rCell As Range, rCell2 As Range

Sub StartTime()
Set ws = Sheets("Calculations")
Set rCell = ws.Range("A1")
PreviousTimerValue = rCell.Value

Set rCell2 = ws.Range("A2") '-----------Cellen den skal tælle ned i
If rCell2 = "" Then rCell2 = TimeValue("01:00:00")
PreviousTimerValue2 = rCell2.Value

Call ExcelStopWatch
End Sub

Private Sub ExcelStopWatch()
rCell.Value = rCell.Value + TimeValue("00:00:01")

With rCell2
    .Value = .Value - TimeValue("00:00:01")
    If .Value < TimeValue("00:01:00") Then ' maler baggrunden rød det sidste minut
        .Interior.ColorIndex = 3
    Else
        .Interior.ColorIndex = 0
    End If
    If .Value = TimeValue("00:00:00") Then .Value = TimeValue("01:00:00") ' når timen er udløbet starter den automatisk på en time igen
End With

NextTick = Now + TimeValue("00:00:01")
Application.OnTime NextTick, "ExcelStopWatch"
End Sub

Sub StopClock()
On Error Resume Next
Application.OnTime earliesttime:=NextTick, procedure:="ExcelStopWatch", schedule:=False
End Sub

Sub Reset()
On Error Resume Next


Application.OnTime earliesttime:=NextTick, procedure:="ExcelStopWatch", schedule:=False
rCell.Value = TimeValue("00:00:00")
rCell2.Value = TimeValue("01:00:00")
End Sub

Option Explicit
'  kodenskal ligge i "Denne_projektmappe"
'----------------------------------------'
    Dim wsA As Worksheet, wsB As Worksheet, rCellA As Range, rCellB As Range
    Set wsA = Sheets("Hovedarket")
    Set wsB = Sheets("Calculations")

Private Sub Workbook_SheetActivate(ByVal Sh As Object) ' kører hvergang et ark bliver aktiveret, variablen sh fanger hvilket ark der er det aktive
    Set rCellA = wsA.Range("A1") ' A1 i hovedarket
    Set rCellB = wsB.Range("A1") ' A1 i biarket
    rCellA.Font = rCellB.Font ' tager font indstillinger med over fra biark til hovedark
End Sub

Option Explicit

Dim wsA As Worksheet, wsB As Worksheet, rCellA As Range, rCellB As Range


Private Sub Workbook_SheetActive(ByVal Sh As Object)

Set wsA = Sheets("Hovedarket")
Set wsB = Sheets("Calculations")

Set rCellA = wsA.Range("B1")
Set rCellB = wsB.Range("B1") ´-------Nedtælleren er i Calculations B1
rCellA.Font = rCellB.Font

End Sub

Option Explicit

Dim wsA As Worksheet, wsB As Worksheet, rCellA As Range, rCellB As Range

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Set wsA = Sheets("Hovedarket")
    Set wsB = Sheets("Calculations")
   
    Set rCellA = wsA.Range("B1")
    Set rCellB = wsB.Range("B1") '-------Nedtælleren er i Calculations B1
    With rCellA.Font
        .Name = rCellB.Font.Name
        .Bold = rCellB.Font.Bold
        .Size = rCellB.Font.Size
        .Color = rCellB.Font.Color
        'osv
    End With
End Sub

Option Explicit

Dim wsA As Worksheet, wsB As Worksheet, rCellA As Range, rCellB As Range

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Set wsA = Sheets("Hovedarket")
    Set wsB = Sheets("Calculations")
   
    If Sh.Name = wsA.Name Then
        Set rCellA = wsA.Range("B1")
        Set rCellB = wsB.Range("B1") '-------Nedtælleren er i Calculations B1
       
        rCellB.Copy
        rCellA.PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
    End If
End Sub