funzione cronometro

[pino]

Vorrei utilizzare excel come cronometro per le gare
scolastiche. Mi spiego. Vorrei realizzare un
pulsante "Start" con il quale segnare il tempo "0"
dell'inizio della gara. Poi, all'arrivo dei concorrenti,
digitare il numero del pettorale e avere automaticamente
il nominativo (semplice, con il cerca.vert su una tabella
predisposta con l'elenco dei concorrenti) ed a fianco il
tempo in minuti - secondi e centesimi, così da avere in
tempo reale la classifica con i tempi.
Ringrazio e saluto con cordialità.
Pino

[SergioBS]

Ciao Pino

Beh io non sono un esperto, ma potresti fare una cosa di questo tipo:

nella colonna a metti il numero di pettorale, nella colonna b il nome in
questo modo:

1 tizio
2 caio
3 sempronio
4 ada
5 bruno
6 carlo
7 dino
8 ermes
9 franco
10 gino
11 horst
12 iole
13 luca
14 mario

e crei un pulsante "Start" su questa pagina:

Copi in un modulo queste due routine:

Sub partenza()
A = Now()
Range("A100") = A
End Sub
Sub Arrivo()
C = Now()
E = C - Range("A100")
col = Application.ActiveCell.Row
Cells(col, 3) = E * 3600 * 24
Range("C2") = E
End Sub

e poi in ThisWorkbook metti:
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target
As Range)
Arrivo
End Sub

in questo modo cliccando con il mouse sulla riga del concorrente vai a
mettere in colonna 3 il suo tempo... poi puoi fare tutte le ricerche che
vuoi...

PS: questo funziona solo con la risoluzione di un Secondo... non so se
esista una funzione per avere i decimi di secondo anche se da con qualche
barbatrucco si riescono sicuramente ad avere...

Sergio

"pino" <anon...@discussions.microsoft.com> ha scritto nel messaggio
news:925e01c43342$00c1de60$a001...@phx.gbl...

[SergioBS]

Scusa... forse č meglio queste formule...

Sub partenza()
A = Now()
Range("A100") = A

Columns("C:C").Select
Selection.NumberFormat = "mm:ss"
Range("E2").Select
Selection.NumberFormat = "mm:ss"
Range("E1") = "Tempo Trascorso"

End Sub
Sub Arrivo()
C = Now()
E = C - Range("A100")
col = Application.ActiveCell.Row
Cells(col, 3) = E

Range("E2") = E
End Sub

> e crei un pulsante "Start" su questa pagina:
al quale abbini la macro "partenza"

[SergioBS]

scusa la fretta... ma avevo dimenticato di mettere un modo per uscire dal
loop (tramite il pulsante "Stop"), e azzerare il tutto all'inizio, inoltre
ho previsto che all'uscita ordina i concorrenti in funzione del tempo....
pertanto copia in un modulo di VB questo:

Sub Start1()
conc = 0
For x = 1 To 200
If Cells(x, 1) <> "" Then conc = conc + 1: Cells(x, 3) = 0
Next
Ordina1 (conc)
A = Now()
Range("A1003") = conc
Range("A1002") = 1
Range("A1001") = A
Range("E2") = 0
Range("E1") = "Tempo Trasc."

Columns("C:C").Select
Selection.NumberFormat = "mm:ss"

Selection.ColumnWidth = 14

Range("E2").Select
Selection.NumberFormat = "mm:ss"

Selection.ColumnWidth = 14

End Sub
Sub Arrivo()
C = Now()

E = C - Range("A1001")

col = Application.ActiveCell.Row
Cells(col, 3) = E
Range("E2") = E
End Sub

Sub Stop1()
Range("A1002") = 0
conc = Range("A1003")
Ordina2 (conc)
End Sub
Sub Ordina1(conc)
Range("A1:C" & conc).Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1")
_
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=
_
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal,
DataOption2 _
:=xlSortNormal
End Sub

Sub Ordina2(conc)
Range("A1:C" & conc).Select
Selection.Sort Key1:=Range("C1"), Order1:=xlAscending, Key2:=Range("B1")
_
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=
_
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal,
DataOption2 _
:=xlSortNormal

End Sub

Sub fai()
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 370.5, 64.5, 47.25,
11.25). _
Select
Selection.Copy
Range("F8").Select
ActiveSheet.Paste
ActiveSheet.Shapes("Rectangle 9").Select
Selection.Characters.Text = "Start"
With Selection.Characters(Start:=1, Length:=5).Font
.Name = "Arial"
.FontStyle = "Normale"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.HorizontalAlignment = xlCenter
ActiveSheet.Shapes("Rectangle 10").Select
Selection.Characters.Text = "Stop"
With Selection.Characters(Start:=1, Length:=4).Font
.Name = "Arial"
.FontStyle = "Normale"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.HorizontalAlignment = xlCenter
ActiveSheet.Shapes("Rectangle 9").Select
Selection.Characters.Text = "Start"
With Selection.Characters(Start:=1, Length:=5).Font
.Name = "Arial"
.FontStyle = "Normale"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.OnAction = "Start1"
ActiveSheet.Shapes("Rectangle 10").Select
ActiveSheet.Shapes("Rectangle 10").Select
Selection.Characters.Text = "Stop"
With Selection.Characters(Start:=1, Length:=4).Font
.Name = "Arial"
.FontStyle = "Normale"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.OnAction = "Stop1"
End Sub

e in ThisWorkbook questo:

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target
As Range)

AC = ActiveCell.Row
conc = Range("A1003")
If AC <= conc Then If Range("A1002") = 1 Then Arrivo
End Sub

se hai problemi a mettere i pulsanti e collegarli, la sub "FAI" fa proprio
quello...

Sarebbe adesso carino gestire anche le frazioni di secondo... cerco in
giro...

Sergio

[SergioBS]

OK, grazie a Jake ho trovato il modo di andare al millesimo di secondo:
basta usare la funzione Timer invece di Now() e dividere il dato per
57600....
Se ti serve un esempio mandami la tua email e ti rispondo in privato

Sergio

"SergioBS" <asda...@asdas.com> ha scritto nel messaggio
news:2fv0a5F...@uni-berlin.de...