Iniciar sesiónCerrar
Correo:
Contraseña:
Entrar
Recordar sesión en este navegador
Iniciar sesiónIniciar sesiónCrear cuentaCrear cuenta
LWP » Foros » Visual Basic para Aplicaciones » Problema con programa para fichar

Visual Basic para Aplicaciones - Problema con programa para fichar

Life is soft - evento anual de software empresarial
Volver
Nuevo Tema
<<>>
 
Vista:
sin imagen de perfil
Val: 59
Ha mantenido su posición en Visual Basic para Aplicaciones (en relación al último mes)
Gráfica de Visual Basic para Aplicaciones

Problema con programa para fichar

Publicado por Manuel (26 intervenciones) el 10/05/2020 12:08:04
Buenos Dias a ver si alguien puede resolverme el problema, ya que estoy adecuando un programa de fichado de trabajadores a mis necesidades, y no consigo hacer que fiche varias entradas y salidas en el mismo dia un mismo trabajador, tiene receso para comer, pero yo lo que necesito es que fichen varias veces al dia ya que el horario es muy flexible, os pego el código del formulario de marcaje a ver si me podeis dar una solución, ya que lo he intentado de varias maneras y no lo consigo, es el mismo código donde he insertado el redondeo de las horas a cuartos que me proporcionasteis, el cual funciona de maravilla:


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
Option Explicit
 
Const Tempus = 1.5 'Segundos
Sub TEMPORAL()
  CreateObject("wscript.shell").Popup _
    "MARCAJE INCORRECTO! " & vbCr & vbCritical & _
                      "LA LECTURA FUE INCORRECTA... INTENTE DE NUEVO !", 1, "MARCAJE INCORRECTO!", vbCritical
End Sub
 
Sub MsgBox_con_Temporizador()
Dim objShell As Object
Dim respuesta1 As Integer, respuesta2 As Integer, respuesta3 As Integer
Set objShell = CreateObject("WScript.Shell")
'Sint?xis M?todo PopUp:  .Popup(Texto,[Tiempo en segundos],[Titulo MsgBox],[Tipo Bot?n])
respuesta2 = objShell.Popup("LA LECTURA FUE INCORRECTA... INTENTE DE NUEVO!", Tempus, "MARCAJE INCORRECTO!", vbCritical)
Set objShell = Nothing
End Sub
 
'---------------------------------------------------------------------------------------------------
Private Sub Bcerrar_Click()
Unload Me: Principal.Show
End Sub
'---------------------------------------------------------------------------------------------------
 
Private Sub BReceso_Click()
Sheets("Recesos").Activate
 
Dim Recode As Integer
Recode = Rece(Cbreceso.Text)
 
If Recode = 0 Then '1'-------------------------------------------------------------------------------------3
      Do While Not IsEmpty(ActiveCell)
      ActiveCell.Offset(1, 0).Activate ' si el registro no existe, se va al final.
      Loop
 
    With ActiveCell.EntireRow.Font '--------------*
    .Name = "Arial"
    .Size = 8
    End With '------------------------------------*
 
 
'Aqui es cuando agregamos o modificamos el registro
    Application.ScreenUpdating = False
    ActiveCell = Tcod2
    ActiveCell.Offset(0, 1) = Tnom:  ActiveCell.Offset(0, 2) = Tape:
    ActiveCell.Offset(0, 3) = Lhora: ActiveCell.Offset(0, 5) = Tfecha
   ' ActiveCell.Offset(0, 5) = Tfecha: ActiveCell.Offset(0, 7) = Tcod2
    ActiveCell.Offset(0, 6) = Tcodigo2: ActiveCell.Offset(0, 7) = Tpla
    ActiveCell.Offset(0, 8) = Lti: ActiveCell.Offset(0, 9) = tcp
 
    Application.ScreenUpdating = True
    'CommandButton1_Click
    ActiveWorkbook.Save: 'Unload Me:  Marcaje.Show:
 
Else
 
Cells(Recode, 2).Select
'Aqui es cuando agregamos o modificamos el registro
Btiempo_Click
   Application.ScreenUpdating = False
 
    ActiveCell = Tcod2
    ActiveCell.Offset(0, 0) = Tnom: ActiveCell.Offset(0, 3) = Lhora
    ActiveCell.Offset(0, 4) = Tfecha: ActiveCell.Offset(0, 5) = Tcodigo2
    ActiveCell.Offset(0, 6) = Tpla: ActiveCell.Offset(0, 7) = Rti
    ActiveCell.Offset(0, 8) = tcp
 
    Application.ScreenUpdating = True
 
    'CommandButton1_Click
 
    ActiveWorkbook.Save: 'Unload Me: Marcaje.Show:
End If '---------------------------------------------------------------------------------------------------3
'End If '---------------------------------------------------------------------------------------------------2
 
End Sub
 
Private Sub Btiempo_Click()
R2 = Lhora
Dim A0, A1 As Variant
A0 = Format(R1, "hh:mm:ss")
A1 = Format(R2, "hh:mm:ss")
 
If R1 = "" Then
Exit Sub
Else
Rti = Format(TimeValue(A1) - TimeValue(A0), "hh:mm:ss")
End If
End Sub
 
Private Sub Cbcode_Change()
Tcod.Text = Cbcode.Text
Tcodigo2 = Tcod + Tfecha + Tpla
On Error Resume Next
If nCode(Cbcode.Text) <> 0 Then
        Sheets("Empleados").Activate
        Cells(Cbcode.ListIndex + 2, 1).Select
        Tnom = ActiveCell.Offset(0, 1): Tape = ActiveCell.Offset(0, 2):
        Ten = ActiveCell.Offset(0, 13): Tsa = ActiveCell.Offset(0, 14):
        Truta3 = ActiveCell.Offset(0, 15)
 
Else
      Tnom = "": Tape = "": Truta3 = "": Ten = "": Tsa = ""
End If
End Sub
 
'---------------------------------------------------------------------------------------------------
 
Private Sub Cbcode2_Change()
On Error Resume Next
If nCode2(Cbcode2.Text) <> 0 Then
       Sheets("Control").Activate
       Cells(Cbcode2.ListIndex + 2, 1).Select
      Tnom = ActiveCell.Offset(0, 1): Tape = ActiveCell.Offset(0, 2):
      Tcod3 = ActiveCell.Offset(0, 8):
 
Else
     Tnom = "": Tape = "": Tcod3 = ""
 
End If
End Sub
'---------------------------------------------------------------------------------------------------
 
Private Sub Cbcode3_Change()
On Error Resume Next
If nCode3(Cbcode3.Text) <> 0 Then
       Sheets("Marcajes").Activate
       Cells(Cbcode3.ListIndex + 2, 1).Select
       The = ActiveCell.Offset(0, 2):
Else
 
     The = ""
     End If
End Sub
'---------------------------------------------------------------------------------------------------
 
Private Sub Cbreceso_Change()
On Error Resume Next
If Reces(Cbreceso.Text) <> 0 Then
       Sheets("recesos").Activate
       Cells(Cbreceso.ListIndex + 2, 1).Select
       R1 = ActiveCell.Offset(0, 3): ' Tcodigo2 = ActiveCell.Offset(0, 9)
Else
     R1 = ""
     End If
End Sub
 
Private Sub CommandButton1_Click()
 
If Tnom = "" Then
Exit Sub
End If
 
Dim P0, P1 As Variant
P1 = Format(Ten, "hh:mm:ss")
P0 = Format(Lhora, "hh:mm:ss")
 
If The = "" And TimeValue(P0) > TimeValue(P1) Then
Ttar = Format(TimeValue(P1) - TimeValue(P0), "hh:mm:ss")
Ttarde = "Tarde" + Tpla
End If
 
 
Sheets("Marcajes").Activate
 
Dim fCode3 As Integer
 
 
fCode3 = nCode3(Tcod2.Text)
 
If fCode3 = 0 Then
      Do While Not IsEmpty(ActiveCell)
      ActiveCell.Offset(1, 0).Activate ' si el registro no existe, se va al final.
 Loop
  With ActiveCell.EntireRow.Font '--------------*
    .Name = "Calibri"
    .Size = 9
    End With '------------------------------------*
 
'Aqui es cuando agregamos o modificamos el registro
    Application.ScreenUpdating = False
    ActiveCell = Tcod2
    'ActiveCell.Offset(0, 0) = Tcod
    ActiveCell.Offset(0, 1) = Tnomc:  ActiveCell.Offset(0, 2) = Lhora: ' ActiveCell.Offset(5, 3) = Thos
    ActiveCell.Offset(0, 4) = Tfecha:
    ActiveCell.Offset(0, 5) = Tcod: ActiveCell.Offset(0, 6) = Tpla
    ActiveCell.Offset(0, 7) = Lti: ActiveCell.Offset(0, 8) = tcp
    ActiveCell.Offset(0, 9) = Ttar: 'ActiveCell.Offset(0, 10) = Tex
    ActiveCell.Offset(0, 11) = Ttarde
 
    Application.ScreenUpdating = True
    ActiveWorkbook.Save:  'Unload Me:  Marcaje.Show:
 
Else
'If fCode3 <> 0 Then
 
Dim D0, D1 As Variant
D1 = Format(Tsa, "hh:mm:ss")
D0 = Format(Lhora, "hh:mm:ss")
 
 
If Thsa = "" And TimeValue(D0) > TimeValue(D1) Then
Tex = Format(TimeValue(D1) - TimeValue(D0), "hh:mm:ss")
Textra = "Extra" + Tpla
End If
 
Thsa = Lhora: R2 = Lhora
 
CommandButton2_Click
 
 
Cells(fCode3, 1).Select
'Aqui es cuando agregamos o modificamos el registro
   Application.ScreenUpdating = False
    ActiveCell = Tcod2
    ActiveCell.Offset(0, 3) = Lhora: ActiveCell.Offset(0, 4) = Tfecha
    ActiveCell.Offset(0, 6) = Tpla: ActiveCell.Offset(0, 7) = Tti
    ActiveCell.Offset(0, 8) = tcp
    'ActiveCell.Offset(0, 9) = Ttar:'ActiveCell.Offset(0, 11) = Ttarde:
    ActiveCell.Offset(0, 10) = Tex: ActiveCell.Offset(0, 12) = Textra
 
 
    Application.ScreenUpdating = True
    ActiveWorkbook.Save: ' Unload Me: Marcaje.Show:
End If
Ttarde = "": Textra = ""
 
End Sub
'---------------------------------------------------------------------------------------------------
 
Private Sub CommandButton2_Click()
Dim t0, t1 As Variant
t0 = Format(The, "hh:mm:ss")
t1 = Format(Thsa, "hh:mm:ss")
 
If The = "" Then
Exit Sub
Else
 
Tti = Format(TimeValue(t1) - TimeValue(t0), "hh:mm:ss")
 
End If
 
End Sub
'---------------------------------------------------------------------------------------------------
 
 
 
Private Sub Receso1_Click()
 
End Sub
 
Private Sub Receso2_Click()
 
End Sub
 
Private Sub Tcod_Change()
If IsNumeric(Tcod.Text) Then
 
Else
Tcod = ""
End If
Tcod2 = Tcod + Tfecha + Tpla: Cbcode2 = Tcod.Text: Cbreceso = Tcod + Tfecha + Tpla
Cbcode.Text = Tcod.Text
 
End Sub
'---------------------------------------------------------------------------------------------------
 
 
Private Sub Tcod_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
 
If KeyCode = 13 Then '------------------------------------------------------------------------------------ 1
 tcp = Tcod + Tpla
 Cbreceso = Tcod + Tfecha + Tpla
'***********************
    If Tnom = "" Then '---------------*
    'TEMPORAL
   MsgBox_con_Temporizador
    Unload Me: Marcaje.Show
    Exit Sub
    End If '--------------------------*
 
 
 
Dim Hor As Byte, Min As Byte
    Hor = Val(Mid(Format(Time, "hh:mm"), 1, 2))
    Min = Val(Mid(Format(Time, "hh:mm"), 4, 2))
    Select Case Min
        Case Is < 7: Min = 0
        Case Is < 22: Min = 15
        Case Is < 37: Min = 30
        Case Is < 52: Min = 45
        Case Is < 59: Min = 0: Hor = Hor + 1
    End Select
    Lhora.Caption = TimeValue(Hor & ":" & Min & ":00")
 
Dim Rece0, Rece1, Hora1 As Variant
Rece0 = Format(Receso1, "hh:mm:ss")
Rece1 = Format(Receso2, "hh:mm:ss")
Hora1 = Format(Lhora, "hh:mm:ss")
'rece0 = 12:55:00, Rece1 = 14:05:00
 
'MsgBox Rece0 & Rece1 & Hora1
If TimeValue(Hora1) >= TimeValue(Rece0) And TimeValue(Hora1) <= TimeValue(Rece1) Then '--------------------------------------------------------------2
BReceso_Click
End If '---------------------------------------------------------------------------------------------------2
 
Sheets("Control").Activate
 
Dim fCode2 As Integer
fCode2 = nCode2(Tcodigo2.Text)
 
If fCode2 = 0 Then '1'-------------------------------------------------------------------------------------3
      Do While Not IsEmpty(ActiveCell)
      ActiveCell.Offset(1, 0).Activate ' si el registro no existe, se va al final.
      Loop
 
    With ActiveCell.EntireRow.Font '--------------*
    .Name = "Arial"
    .Size = 8
    End With '------------------------------------*
 
 
'Aqui es cuando agregamos o modificamos el registro
    Application.ScreenUpdating = False
    ActiveCell = Tcodigo2
    ActiveCell.Offset(0, 1) = Tnom:  ActiveCell.Offset(0, 2) = Tape:
    ActiveCell.Offset(0, 3) = Lhora: ActiveCell.Offset(0, 5) = Tfecha
   ' ActiveCell.Offset(0, 5) = Tfecha: ActiveCell.Offset(0, 7) = Tcod2
    ActiveCell.Offset(0, 6) = Tcod2: ActiveCell.Offset(0, 7) = Tpla
 
    Application.ScreenUpdating = True
CommandButton1_Click
 
    ActiveWorkbook.Save: Unload Me:  Marcaje.Show:
 
Else
 
Cells(fCode2, 2).Select
'Aqui es cuando agregamos o modificamos el registro
   Application.ScreenUpdating = False
    ActiveCell = Tcodigo2
    ActiveCell.Offset(0, 0) = Tnom: ActiveCell.Offset(0, 3) = Lhora
    ActiveCell.Offset(0, 4) = Tfecha: ActiveCell.Offset(0, 5) = Tcod2
    ActiveCell.Offset(0, 6) = Tpla
 
    Application.ScreenUpdating = True
CommandButton1_Click
 
    ActiveWorkbook.Save: Unload Me: Marcaje.Show:
End If '---------------------------------------------------------------------------------------------------3
 
End If '---------------------------------------------------------------------------------------------------1
 
 
 
'**************************************************************************************************************************************************************
End Sub
'---------------------------------------------------------------------------------------------------
 
Private Sub Tcod2_Change()
Cbcode3 = Tcod2
End Sub
 
 
 
Private Sub Tfecha_Change()
Tcodigo2 = Tcod + Tfecha + Tpla
End Sub
 
Private Sub Tnom_Change()
Tnomc = Tnom + " " + Tape
 
If Tnom <> "" Then
Lhora.Visible = True
Else
Lhora.Visible = False
End If
End Sub
Private Sub Tape_Change()
Tnomc = Tnom + " " + Tape
 
If Tape <> "" Then
Lhora.Visible = True
Else
Lhora.Visible = False
End If
End Sub
 
Private Sub Tnomc_Change()
 
End Sub
 
Private Sub Tpla_Change()
Tcodigo2 = Tcod + Tfecha + Tpla
End Sub
 
Private Sub Truta3_Change()
If Truta3 <> "" Then
Image1.Picture = LoadPicture(Truta3)
Else
Image1.Picture = LoadPicture(Truta2)
End If
End Sub
 
Private Sub UserForm_Activate()
    Dim Hor As Byte, Min As Byte
    Hor = Val(Mid(Format(Time, "hh:mm"), 1, 2))
    Min = Val(Mid(Format(Time, "hh:mm"), 4, 2))
    Select Case Min
        Case Is < 7: Min = 0
        Case Is < 22: Min = 15
        Case Is < 37: Min = 30
        Case Is < 52: Min = 45
        Case Is < 59: Min = 0: Hor = Hor + 1
    End Select
    Lhora = TimeValue(Hor & ":" & Min & ":00")
Tpla = weeknum(Tfecha):
Tcod2 = Tcod + Tfecha + Tpla
Lti.Caption = "0:00:00"
 
End Sub
'---------------------------------------------------------------------------------------------------
 
Private Sub UserForm_Initialize()
 
Dim rango, celda As Range
Set rango = Worksheets("Empleados").Range("Listado_emp")
 
For Each celda In rango
Cbcode.AddItem celda.Value
 
Next celda
Cbcode.Text = Worksheets("Empleados").Range("A2")
 
Dim rango1, celda1 As Range
Set rango1 = Worksheets("Control").Range("Listado_mar")
 
For Each celda1 In rango1
Cbcode2.AddItem celda1.Value
 
Next celda1
'Cbcode2.Text = Worksheets("Control").Range("A2")
 
'**************************************************************************************
 
Dim rango2, celda2 As Range
Set rango2 = Worksheets("Marcajes").Range("Listado_cod")
 
For Each celda2 In rango2
Cbcode3.AddItem celda2.Value
 
Next celda2
'Cbcode3.Text = Worksheets("Marcajes").Range("A2")
'*************************************************************************************
 
Dim rangoA, celdaA As Range
Set rangoA = Worksheets("recesos").Range("Listado_rec")
 
For Each celdaA In rangoA
Cbreceso.AddItem celdaA.Value
 
Next celdaA
 
'*************************************************************************************
 
Tfecha = Date
Cbcode2.Text = Cbcode.Text
Tcod = ""
End Sub
 
 
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Dim qq As String
If CloseMode = 0 Then
qq = Chr(34): Cancel = 1
End If
End Sub


Muchisimas gracias.
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder
Imágen de perfil de Antoni Masana
Val: 1.134
Oro
Ha mantenido su posición en Visual Basic para Aplicaciones (en relación al último mes)
Gráfica de Visual Basic para Aplicaciones

Problema con programa para fichar

Publicado por Antoni Masana (502 intervenciones) el 11/05/2020 10:06:52
He revisado el código, lo he sangrado para leerlo mejor.

No se que son la mitad de las cosas (variables u objetos), no se que quieres hacer, no se que quieres hacer, no se como lo haces y no se que hace el programa. Estos tres últimos conceptos aunque parecen lo mismo no lo son.

El comentarío hablas un problema sin especificar, vamos que son muchos "no se" para darte una solución.
Es aconsejable poner comentarios de que se hace en cada momento, siempre es una gran ayuda en el futuro.

También seria conveniente que subieses un libro de ejemplo.


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
Option Explicit
 
Const Tempus = 1.5 'Segundos
 
Sub TEMPORAL()
    CreateObject("wscript.shell").Popup _
                  "MARCAJE INCORRECTO! " & vbCr & vbCritical & _
                  "LA LECTURA FUE INCORRECTA... INTENTE DE NUEVO !", 1, _
                  "MARCAJE INCORRECTO!", vbCritical
End Sub
 
Sub MsgBox_con_Temporizador()
    Dim objShell As Object
    Dim respuesta1 As Integer, respuesta2 As Integer, respuesta3 As Integer
    Set objShell = CreateObject("WScript.Shell")
    '--- Sint?xis M?todo PopUp:  .Popup(Texto,[Tiempo en segundos],
    '                                         [Titulo MsgBox],[Tipo Bot?n])
    respuesta2 = objShell.Popup("LA LECTURA FUE INCORRECTA... INTENTE DE NUEVO!", _
                                Tempus, "MARCAJE INCORRECTO!", vbCritical)
    Set objShell = Nothing
End Sub
 
Private Sub Bcerrar_Click()
    Unload Me: Principal.Show
End Sub
 
Private Sub BReceso_Click()
    Sheets("Recesos").Activate
 
    Dim Recode As Integer
    Recode = Rece(Cbreceso.Text)
 
    If Recode = 0 Then
        Do While Not IsEmpty(ActiveCell)
            ActiveCell.Offset(1, 0).Activate ' si el registro no existe, se va al final.
        Loop
 
        With ActiveCell.EntireRow.Font
            .Name = "Arial"
            .Size = 8
        End With
 
        ' --- Aqui es cuando agregamos o modificamos el registro
        Application.ScreenUpdating = False
        ActiveCell = Tcod2
        ActiveCell.Offset(0, 1) = Tnom:  ActiveCell.Offset(0, 2) = Tape:
        ActiveCell.Offset(0, 3) = Lhora: ActiveCell.Offset(0, 5) = Tfecha
        ActiveCell.Offset(0, 6) = Tcodigo2: ActiveCell.Offset(0, 7) = Tpla
        ActiveCell.Offset(0, 8) = Lti: ActiveCell.Offset(0, 9) = tcp
 
        Application.ScreenUpdating = True
        ActiveWorkbook.Save
    Else
        Cells(Recode, 2).Select
        ' --- Aqui es cuando agregamos o modificamos el registro
        Btiempo_Click
        Application.ScreenUpdating = False
 
        ActiveCell = Tcod2
        ActiveCell.Offset(0, 0) = Tnom: ActiveCell.Offset(0, 3) = Lhora
        ActiveCell.Offset(0, 4) = Tfecha: ActiveCell.Offset(0, 5) = Tcodigo2
        ActiveCell.Offset(0, 6) = Tpla: ActiveCell.Offset(0, 7) = Rti
        ActiveCell.Offset(0, 8) = tcp
 
        Application.ScreenUpdating = True
        ActiveWorkbook.Save
    End If
End Sub
 
Private Sub Btiempo_Click()
    R2 = Lhora
    Dim A0, A1 As Variant
    A0 = Format(R1, "hh:mm:ss")
    A1 = Format(R2, "hh:mm:ss")
 
    If R1 = "" Then
        Exit Sub
    Else
        Rti = Format(TimeValue(A1) - TimeValue(A0), "hh:mm:ss")
    End If
End Sub
 
Private Sub Cbcode_Change()
    Tcod.Text = Cbcode.Text
    Tcodigo2 = Tcod + Tfecha + Tpla
    On Error Resume Next
    If nCode(Cbcode.Text) <> 0 Then
        Sheets("Empleados").Activate
        Cells(Cbcode.ListIndex + 2, 1).Select
        Tnom = ActiveCell.Offset(0, 1): Tape = ActiveCell.Offset(0, 2):
        Ten = ActiveCell.Offset(0, 13): Tsa = ActiveCell.Offset(0, 14):
        Truta3 = ActiveCell.Offset(0, 15)
    Else
        Tnom = "": Tape = "": Truta3 = "": Ten = "": Tsa = ""
    End If
End Sub
 
Private Sub Cbcode2_Change()
    On Error Resume Next
    If nCode2(Cbcode2.Text) <> 0 Then
        Sheets("Control").Activate
        Cells(Cbcode2.ListIndex + 2, 1).Select
        Tnom = ActiveCell.Offset(0, 1): Tape = ActiveCell.Offset(0, 2):
        Tcod3 = ActiveCell.Offset(0, 8):
    Else
        Tnom = "": Tape = "": Tcod3 = ""
    End If
End Sub
 
Private Sub Cbcode3_Change()
    On Error Resume Next
    If nCode3(Cbcode3.Text) <> 0 Then
        Sheets("Marcajes").Activate
        Cells(Cbcode3.ListIndex + 2, 1).Select
        The = ActiveCell.Offset(0, 2):
    Else
        The = ""
    End If
End Sub
 
Private Sub Cbreceso_Change()
    On Error Resume Next
    If Reces(Cbreceso.Text) <> 0 Then
        Sheets("recesos").Activate
        Cells(Cbreceso.ListIndex + 2, 1).Select
        R1 = ActiveCell.Offset(0, 3):
    Else
        R1 = ""
    End If
End Sub
 
Private Sub CommandButton1_Click()
    If Tnom = "" Then
        Exit Sub
    End If
 
    Dim P0, P1 As Variant
    P1 = Format(Ten, "hh:mm:ss")
    P0 = Format(Lhora, "hh:mm:ss")
 
    If The = "" And TimeValue(P0) > TimeValue(P1) Then
         Ttar = Format(TimeValue(P1) - TimeValue(P0), "hh:mm:ss")
         Ttarde = "Tarde" + Tpla
    End If
 
    Sheets("Marcajes").Activate
    Dim fCode3 As Integer
    fCode3 = nCode3(Tcod2.Text)
 
    If fCode3 = 0 Then
        Do While Not IsEmpty(ActiveCell)
            ActiveCell.Offset(1, 0).Activate ' si el registro no existe, se va al final.
        Loop
        With ActiveCell.EntireRow.Font
            .Name = "Calibri"
            .Size = 9
        End With
 
        ' --- Aqui es cuando agregamos o modificamos el registro
        Application.ScreenUpdating = False
        ActiveCell = Tcod2
        ActiveCell.Offset(0, 1) = Tnomc:  ActiveCell.Offset(0, 2) = Lhora
        ActiveCell.Offset(0, 4) = Tfecha:
        ActiveCell.Offset(0, 5) = Tcod: ActiveCell.Offset(0, 6) = Tpla
        ActiveCell.Offset(0, 7) = Lti: ActiveCell.Offset(0, 8) = tcp
        ActiveCell.Offset(0, 9) = Ttar
        ActiveCell.Offset(0, 11) = Ttarde
 
        Application.ScreenUpdating = True
        ActiveWorkbook.Save
    Else
        Dim D0, D1 As Variant
        D1 = Format(Tsa, "hh:mm:ss")
        D0 = Format(Lhora, "hh:mm:ss")
        If Thsa = "" And TimeValue(D0) > TimeValue(D1) Then
            Tex = Format(TimeValue(D1) - TimeValue(D0), "hh:mm:ss")
            Textra = "Extra" + Tpla
        End If
        Thsa = Lhora: R2 = Lhora
        CommandButton2_Click
        Cells(fCode3, 1).Select
        ' --- Aqui es cuando agregamos o modificamos el registro
        Application.ScreenUpdating = False
        ActiveCell = Tcod2
        ActiveCell.Offset(0, 3) = Lhora: ActiveCell.Offset(0, 4) = Tfecha
        ActiveCell.Offset(0, 6) = Tpla: ActiveCell.Offset(0, 7) = Tti
        ActiveCell.Offset(0, 8) = tcp
        ActiveCell.Offset(0, 10) = Tex: ActiveCell.Offset(0, 12) = Textra
 
        Application.ScreenUpdating = True
        ActiveWorkbook.Save
    End If
    Ttarde = "": Textra = ""
End Sub
 
Private Sub CommandButton2_Click()
    Dim t0, t1 As Variant
    t0 = Format(The, "hh:mm:ss")
    t1 = Format(Thsa, "hh:mm:ss")
 
    If The = "" Then
        Exit Sub
    Else
        Tti = Format(TimeValue(t1) - TimeValue(t0), "hh:mm:ss")
    End If
End Sub
 
Private Sub Tcod_Change()
    If Not IsNumeric(Tcod.Text) Then Tcod = ""
    Tcod2 = Tcod + Tfecha + Tpla
    Cbcode2 = Tcod.Text
    Cbreceso = Tcod + Tfecha + Tpla
    Cbcode.Text = Tcod.Text
End Sub
 
Private Sub Tcod_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = 13 Then
        tcp = Tcod + Tpla
        Cbreceso = Tcod + Tfecha + Tpla
 
        If Tnom = "" Then
            'TEMPORAL
            MsgBox_con_Temporizador
            Unload Me: Marcaje.Show
            Exit Sub
        End If
 
        Dim Hor As Byte, Min As Byte
        Hor = Val(Mid(Format(Time, "hh:mm"), 1, 2))
        Min = Val(Mid(Format(Time, "hh:mm"), 4, 2))
        Select Case Min
            Case Is < 7: Min = 0
            Case Is < 22: Min = 15
            Case Is < 37: Min = 30
            Case Is < 52: Min = 45
            Case Is < 59: Min = 0: Hor = Hor + 1
        End Select
        Lhora.Caption = TimeValue(Hor & ":" & Min & ":00")
 
        Dim Rece0, Rece1, Hora1 As Variant
        Rece0 = Format(Receso1, "hh:mm:ss")
        Rece1 = Format(Receso2, "hh:mm:ss")
        Hora1 = Format(Lhora, "hh:mm:ss")
 
        'MsgBox Rece0 & Rece1 & Hora1
        If TimeValue(Hora1) >= TimeValue(Rece0) And _
           TimeValue(Hora1) <= TimeValue(Rece1) Then
            BReceso_Click
        End If
        Sheets("Control").Activate
 
        Dim fCode2 As Integer
        fCode2 = nCode2(Tcodigo2.Text)
 
        If fCode2 = 0 Then
            Do While Not IsEmpty(ActiveCell)
                ActiveCell.Offset(1, 0).Activate ' si el registro no existe, se va al final.
            Loop
 
            With ActiveCell.EntireRow.Font
                .Name = "Arial"
                .Size = 8
            End With
 
            ' --- Aqui es cuando agregamos o modificamos el registro
            Application.ScreenUpdating = False
            ActiveCell = Tcodigo2
            ActiveCell.Offset(0, 1) = Tnom:  ActiveCell.Offset(0, 2) = Tape:
            ActiveCell.Offset(0, 3) = Lhora: ActiveCell.Offset(0, 5) = Tfecha
            ActiveCell.Offset(0, 6) = Tcod2: ActiveCell.Offset(0, 7) = Tpla
            Application.ScreenUpdating = True
            CommandButton1_Click
 
            ActiveWorkbook.Save: Unload Me:  Marcaje.Show:
        Else
            Cells(fCode2, 2).Select
            ' --- Aqui es cuando agregamos o modificamos el registro
            Application.ScreenUpdating = False
            ActiveCell = Tcodigo2
            ActiveCell.Offset(0, 0) = Tnom: ActiveCell.Offset(0, 3) = Lhora
            ActiveCell.Offset(0, 4) = Tfecha: ActiveCell.Offset(0, 5) = Tcod2
            ActiveCell.Offset(0, 6) = Tpla
 
            Application.ScreenUpdating = True
            CommandButton1_Click
 
            ActiveWorkbook.Save: Unload Me: Marcaje.Show:
        End If
    End If
End Sub
 
Private Sub Tcod2_Change()
    Cbcode3 = Tcod2
End Sub
 
Private Sub Tfecha_Change()
    Tcodigo2 = Tcod + Tfecha + Tpla
End Sub
 
Private Sub Tnom_Change()
    Tnomc = Tnom + " " + Tape
    If Tnom <> "" Then
        Lhora.Visible = True
    Else
        Lhora.Visible = False
    End If
End Sub
 
Private Sub Tape_Change()
    Tnomc = Tnom + " " + Tape
    If Tape <> "" Then
        Lhora.Visible = True
    Else
        Lhora.Visible = False
    End If
End Sub
 
Private Sub Tpla_Change()
    Tcodigo2 = Tcod + Tfecha + Tpla
End Sub
 
Private Sub Truta3_Change()
    If Truta3 <> "" Then
        Image1.Picture = LoadPicture(Truta3)
    Else
        Image1.Picture = LoadPicture(Truta2)
    End If
End Sub
 
Private Sub UserForm_Activate()
    Dim Hor As Byte, Min As Byte
    Hor = Val(Mid(Format(Time, "hh:mm"), 1, 2))
    Min = Val(Mid(Format(Time, "hh:mm"), 4, 2))
    Select Case Min
        Case Is < 7: Min = 0
        Case Is < 22: Min = 15
        Case Is < 37: Min = 30
        Case Is < 52: Min = 45
        Case Is < 59: Min = 0: Hor = Hor + 1
    End Select
    Lhora = TimeValue(Hor & ":" & Min & ":00")
    Tpla = weeknum(Tfecha):
    Tcod2 = Tcod + Tfecha + Tpla
    Lti.Caption = "0:00:00"
End Sub
 
Private Sub UserForm_Initialize()
    Dim rango, celda As Range
    Set rango = Worksheets("Empleados").Range("Listado_emp")
 
    For Each celda In rango
        Cbcode.AddItem celda.Value
    Next celda
    Cbcode.Text = Worksheets("Empleados").Range("A2")
 
    Dim rango1, celda1 As Range
    Set rango1 = Worksheets("Control").Range("Listado_mar")
 
    For Each celda1 In rango1
        Cbcode2.AddItem celda1.Value
    Next celda1
 
    Dim rango2, celda2 As Range
    Set rango2 = Worksheets("Marcajes").Range("Listado_cod")
 
    For Each celda2 In rango2
        Cbcode3.AddItem celda2.Value
    Next celda2
    Dim rangoA, celdaA As Range
    Set rangoA = Worksheets("recesos").Range("Listado_rec")
 
    For Each celdaA In rangoA
        Cbreceso.AddItem celdaA.Value
    Next celdaA
    Tfecha = Date
    Cbcode2.Text = Cbcode.Text
    Tcod = ""
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Dim qq As String
    If CloseMode = 0 Then  qq = Chr(34): Cancel = 1
End Sub

Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 59
Ha mantenido su posición en Visual Basic para Aplicaciones (en relación al último mes)
Gráfica de Visual Basic para Aplicaciones

Problema con programa para fichar

Publicado por Manuel (26 intervenciones) el 11/05/2020 20:00:04
El código es del formulario de marcajes, adjunto unas capturas de pantalla con las hojas "marcajes", "recesos" y "control" del libro.
Este código es del formulario de fichajes, en el cual los empleados van a fichar con un código de barras, código que les asigno en otra pagina del libro que se llama empleados junto con el nombre, dirección, DNI, telef, etc.
El problema que tengo es que quisiera quitar los recesos y poder fichar varias entradas y salidas en el mismo dia por un mismo trabajador.
Ya que los empleados no tienen una jornada laboral definida con una hora de entrada y una de salida y a veces hacen varios turnos durante las 8 horas diarias.
Algunos eventos del código no me sirven para nada como el control de horas extras o de si llegan tarde.
Lo que quiero es arreglar el código para que un empleado haga varias fichadas en un mismo dia sin problemas, cosa que ahora no puedo.
Siento no haberme explicado bien, gracias.
A continuación te explico cuales son las variables, y eventos que quiero cambiar:


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
Option Explicit    'Lo dejamos asi, esto es el tiempo que tiene que estar abierto el aviso de que no se ha fichado bien
 
Const Tempus = 1.5 'Segundos
 
Sub TEMPORAL() 'esta bien aviso de que no se ha fichado bien
  CreateObject("wscript.shell").Popup _
    "MARCAJE INCORRECTO! " & vbCr & vbCritical & _
                      "LA LECTURA FUE INCORRECTA... INTENTE DE NUEVO !", 1, "MARCAJE INCORRECTO!", vbCritical
End Sub
 
Sub MsgBox_con_Temporizador() 'también esta bien para cuando se ficha mal
Dim objShell As Object
Dim respuesta1 As Integer, respuesta2 As Integer, respuesta3 As Integer
Set objShell = CreateObject("WScript.Shell")
'Sint?xis M?todo PopUp:  .Popup(Texto,[Tiempo en segundos],[Titulo MsgBox],[Tipo Bot?n])
respuesta2 = objShell.Popup("LA LECTURA FUE INCORRECTA... INTENTE DE NUEVO!", Tempus, "MARCAJE INCORRECTO!", vbCritical)
Set objShell = Nothing
End Sub
 
'---------------------------------------------------------------------------------------------------
Private Sub Bcerrar_Click()  'esto tambien esta bien para volver al formulario principal
Unload Me: Principal.Show
End Sub
'---------------------------------------------------------------------------------------------------
 
Private Sub BReceso_Click()  'Aquí es donde no quiero que me haga receso o descanso para comer, sino que me permita fichar varias entradas y salidas de un mismo trabajador en un mismo dia, no se si seria mejor quitar este evento y la hoja de recesos del libro o reformarlo
Sheets("Recesos").Activate
 
Dim Recode As Integer ' PARA IDENTIFICAR SI ES UN RECESO O NO
Recode = Rece(Cbreceso.Text)
 
If Recode = 0 Then '1'-------------------------------------------------------------------------------------3
      Do While Not IsEmpty(ActiveCell)
      ActiveCell.Offset(1, 0).Activate ' si el registro no existe, se va al final.
      Loop
 
    With ActiveCell.EntireRow.Font '--------------*
    .Name = "Arial"
    .Size = 8
    End With '------------------------------------*
 
 
'Aqui es cuando agregamos o modificamos el registro
    Application.ScreenUpdating = False
    ActiveCell = Tcod2 'Tcod2= Tcod (código empleado) + Tfecha (fecha captada) + Tpla (nº semana)
    ActiveCell.Offset(0, 1) = Tnom:  ActiveCell.Offset(0, 2) = Tape:  'Tnom es el nombre del empleado Tape son los apellidos
    ActiveCell.Offset(0, 3) = Lhora: ActiveCell.Offset(0, 5) = Tfecha 'Lhora es la hora captada en cuartos y Tfecha es la fecha
   ' ActiveCell.Offset(0, 5) = Tfecha: ActiveCell.Offset(0, 7) = Tcod2
    ActiveCell.Offset(0, 6) = Tcodigo2: ActiveCell.Offset(0, 7) = Tpla ' Tcodigo2 es el código de receso Tpla es el numero de semana
    ActiveCell.Offset(0, 8) = Lti: ActiveCell.Offset(0, 9) = tcp ' Lti es el tiempo trabajado y tcp = Tcod (código empleado) + Tpla (nº semana)
 
    Application.ScreenUpdating = True
    'CommandButton1_Click
    ActiveWorkbook.Save: 'Unload Me:  Marcaje.Show:
 
Else
 
Cells(Recode, 2).Select
'Aqui es cuando agregamos o modificamos el registro
Btiempo_Click
   Application.ScreenUpdating = False
 
    ActiveCell = Tcod2
    ActiveCell.Offset(0, 0) = Tnom: ActiveCell.Offset(0, 3) = Lhora
    ActiveCell.Offset(0, 4) = Tfecha: ActiveCell.Offset(0, 5) = Tcodigo2
    ActiveCell.Offset(0, 6) = Tpla: ActiveCell.Offset(0, 7) = Rti 'es el tiempo trabajado en el segundo fichaje de receso
    ActiveCell.Offset(0, 8) = tcp
 
    Application.ScreenUpdating = True
 
    'CommandButton1_Click
 
    ActiveWorkbook.Save: 'Unload Me: Marcaje.Show:
End If '---------------------------------------------------------------------------------------------------3
'End If '---------------------------------------------------------------------------------------------------2
 
End Sub
 
Private Sub Btiempo_Click()
R2 = Lhora
Dim A0, A1 As Variant
A0 = Format(R1, "hh:mm:ss") ' R1 es la hora captada en la entrada del receso
A1 = Format(R2, "hh:mm:ss") ' R2 es la hora captada en la salida del receso
 
If R1 = "" Then
Exit Sub
Else
Rti = Format(TimeValue(A1) - TimeValue(A0), "hh:mm:ss")
End If
End Sub
 
Private Sub Cbcode_Change()
Tcod.Text = Cbcode.Text
Tcodigo2 = Tcod + Tfecha + Tpla
On Error Resume Next
If nCode(Cbcode.Text) <> 0 Then
        Sheets("Empleados").Activate
        Cells(Cbcode.ListIndex + 2, 1).Select
        Tnom = ActiveCell.Offset(0, 1): Tape = ActiveCell.Offset(0, 2): ' nombre y apellidos
        Ten = ActiveCell.Offset(0, 13): Tsa = ActiveCell.Offset(0, 14): ' Ten y Tsa (Entradas y salidas para horarios fijos, si llegan tarde o fuera
        Truta3 = ActiveCell.Offset(0, 15) 'es para la foto del trabajador                                                           de hora, esto no me sirve)
 
Else
      Tnom = "": Tape = "": Truta3 = "": Ten = "": Tsa = ""
End If
End Sub
 
'---------------------------------------------------------------------------------------------------
 
Private Sub Cbcode2_Change()
On Error Resume Next
If nCode2(Cbcode2.Text) <> 0 Then 'Cbcode, Cbcode2, Cbcode3 están en el evento Initialize, al final del codigo
       Sheets("Control").Activate
       Cells(Cbcode2.ListIndex + 2, 1).Select
      Tnom = ActiveCell.Offset(0, 1): Tape = ActiveCell.Offset(0, 2):
      Tcod3 = ActiveCell.Offset(0, 8): 'Tcod3 (código trabajador + semana del año)
 
Else
     Tnom = "": Tape = "": Tcod3 = ""
 
End If
End Sub
'---------------------------------------------------------------------------------------------------
 
Private Sub Cbcode3_Change()
On Error Resume Next
If nCode3(Cbcode3.Text) <> 0 Then
       Sheets("Marcajes").Activate
       Cells(Cbcode3.ListIndex + 2, 1).Select
       The = ActiveCell.Offset(0, 2): 'The (hora entrada)
Else
 
     The = ""
     End If
End Sub
'---------------------------------------------------------------------------------------------------
 
Private Sub Cbreceso_Change()
On Error Resume Next
If Reces(Cbreceso.Text) <> 0 Then
       Sheets("recesos").Activate
       Cells(Cbreceso.ListIndex + 2, 1).Select
       R1 = ActiveCell.Offset(0, 3): ' Tcodigo2 = ActiveCell.Offset(0, 9)
Else
     R1 = ""
     End If
End Sub
 
Private Sub CommandButton1_Click()
 
If Tnom = "" Then
Exit Sub
End If
 
Dim P0, P1 As Variant
P1 = Format(Ten, "hh:mm:ss")
P0 = Format(Lhora, "hh:mm:ss")
 
If The = "" And TimeValue(P0) > TimeValue(P1) Then              'estas cuatro líneas son para ver si el empleado ha llegado tarde, como yo
Ttar = Format(TimeValue(P1) - TimeValue(P0), "hh:mm:ss")                                     'no tengo horarios fijos esto no me sirve
Ttarde = "Tarde" + Tpla
End If
 
 
Sheets("Marcajes").Activate 'Aquí hace marcajes no recesos
 
Dim fCode3 As Integer
 
 
fCode3 = nCode3(Tcod2.Text)
 
If fCode3 = 0 Then
      Do While Not IsEmpty(ActiveCell)
      ActiveCell.Offset(1, 0).Activate ' si el registro no existe, se va al final.
 Loop
  With ActiveCell.EntireRow.Font '--------------*
    .Name = "Calibri"
    .Size = 9
    End With '------------------------------------*
'Cuando fichamos para entrar
 
'Aqui es cuando agregamos o modificamos el registro
    Application.ScreenUpdating = False
    ActiveCell = Tcod2
    'ActiveCell.Offset(0, 0) = Tcod ' código empleado, fecha y num semana
    ActiveCell.Offset(0, 1) = Tnomc:  ActiveCell.Offset(0, 2) = Lhora: ' ActiveCell.Offset(5, 3) = Thos  nombre de empleado y hora
    ActiveCell.Offset(0, 4) = Tfecha:' fecha
    ActiveCell.Offset(0, 5) = Tcod: ActiveCell.Offset(0, 6) = Tpla 'cod empleado la fecha y num semana se descarta, Tpla num de semana
    ActiveCell.Offset(0, 7) = Lti: ActiveCell.Offset(0, 8) = tcp 'Lti tiempo trabajado y tcp código empleado + semana del año
    ActiveCell.Offset(0, 9) = Ttar: 'ActiveCell.Offset(0, 10) = Tex
    ActiveCell.Offset(0, 11) = Ttarde ' Ttar, Tex y Ttarde son parasi alguien llega tarde y horas extra, esto a mi no me sirve
 
    Application.ScreenUpdating = True
    ActiveWorkbook.Save:  'Unload Me:  Marcaje.Show:
 
Else
'If fCode3 <> 0 Then
 
Dim D0, D1 As Variant
D1 = Format(Tsa, "hh:mm:ss")
D0 = Format(Lhora, "hh:mm:ss")
 
 
If Thsa = "" And TimeValue(D0) > TimeValue(D1) Then
Tex = Format(TimeValue(D1) - TimeValue(D0), "hh:mm:ss")
Textra = "Extra" + Tpla
End If
 
Thsa = Lhora: R2 = Lhora
 
CommandButton2_Click
 
 'Cuando fichamos para salir
Cells(fCode3, 1).Select
'Aqui es cuando agregamos o modificamos el registro
   Application.ScreenUpdating = False
    ActiveCell = Tcod2
    ActiveCell.Offset(0, 3) = Lhora: ActiveCell.Offset(0, 4) = Tfecha
    ActiveCell.Offset(0, 6) = Tpla: ActiveCell.Offset(0, 7) = Tti 'Tti tiempo trabajado total en el dia
    ActiveCell.Offset(0, 8) = tcp
    'ActiveCell.Offset(0, 9) = Ttar:'ActiveCell.Offset(0, 11) = Ttarde:
    ActiveCell.Offset(0, 10) = Tex: ActiveCell.Offset(0, 12) = Textra ' estas dos líneas son para fichajes tarde y para horas extra no me sirven
 
 
    Application.ScreenUpdating = True
    ActiveWorkbook.Save: ' Unload Me: Marcaje.Show:
End If
Ttarde = "": Textra = ""
 
End Sub
'---------------------------------------------------------------------------------------------------
 
Private Sub CommandButton2_Click()
Dim t0, t1 As Variant
t0 = Format(The, "hh:mm:ss") 'hora entrada
t1 = Format(Thsa, "hh:mm:ss") 'hora salida
 
If The = "" Then
Exit Sub
Else
 
Tti = Format(TimeValue(t1) - TimeValue(t0), "hh:mm:ss")
 
End If
 
End Sub
'---------------------------------------------------------------------------------------------------
 
 
 
Private Sub Receso1_Click()
 
End Sub
 
Private Sub Receso2_Click()
 
End Sub
 
Private Sub Tcod_Change()
If IsNumeric(Tcod.Text) Then
 
Else
Tcod = ""
End If
Tcod2 = Tcod + Tfecha + Tpla: Cbcode2 = Tcod.Text: Cbreceso = Tcod + Tfecha + Tpla
Cbcode.Text = Tcod.Text
 
End Sub
'---------------------------------------------------------------------------------------------------
 
 
Private Sub Tcod_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
 
If KeyCode = 13 Then '------------------------------------------------------------------------------------ 1
 tcp = Tcod + Tpla
 Cbreceso = Tcod + Tfecha + Tpla
'***********************
    If Tnom = "" Then '---------------*
    'TEMPORAL
   MsgBox_con_Temporizador
    Unload Me: Marcaje.Show
    Exit Sub
    End If '--------------------------*
 
 
 
Dim Hor As Byte, Min As Byte
    Hor = Val(Mid(Format(Time, "hh:mm"), 1, 2))
    Min = Val(Mid(Format(Time, "hh:mm"), 4, 2))
    Select Case Min
        Case Is < 7: Min = 0
        Case Is < 22: Min = 15
        Case Is < 37: Min = 30
        Case Is < 52: Min = 45
        Case Is < 59: Min = 0: Hor = Hor + 1
    End Select
    Lhora.Caption = TimeValue(Hor & ":" & Min & ":00")
 
Dim Rece0, Rece1, Hora1 As Variant
Rece0 = Format(Receso1, "hh:mm:ss") ' marcaje de receso
Rece1 = Format(Receso2, "hh:mm:ss")  ' marcaje de receso
Hora1 = Format(Lhora, "hh:mm:ss") ' marcaje  normal
'rece0 = 12:55:00, Rece1 = 14:05:00 'horas entre las que se habilita marcar un receso
 
'MsgBox Rece0 & Rece1 & Hora1
If TimeValue(Hora1) >= TimeValue(Rece0) And TimeValue(Hora1) <= TimeValue(Rece1) Then '--------------------------------------------------------------2
BReceso_Click
End If '---------------------------------------------------------------------------------------------------2
 
Sheets("Control").Activate 'este código es para marcar también en la hoja CONTROL
 
Dim fCode2 As Integer
fCode2 = nCode2(Tcodigo2.Text)
 
If fCode2 = 0 Then '1'-------------------------------------------------------------------------------------3
      Do While Not IsEmpty(ActiveCell)
      ActiveCell.Offset(1, 0).Activate ' si el registro no existe, se va al final.
      Loop
 
    With ActiveCell.EntireRow.Font '--------------*
    .Name = "Arial"
    .Size = 8
    End With '------------------------------------*
 
 
'Aqui es cuando agregamos o modificamos el registro
    Application.ScreenUpdating = False
    ActiveCell = Tcodigo2
    ActiveCell.Offset(0, 1) = Tnom:  ActiveCell.Offset(0, 2) = Tape: ' Nombre y apellidos
    ActiveCell.Offset(0, 3) = Lhora: ActiveCell.Offset(0, 5) = Tfecha ' Hora y Fecha
   ' ActiveCell.Offset(0, 5) = Tfecha: ActiveCell.Offset(0, 7) = Tcod2
    ActiveCell.Offset(0, 6) = Tcod2: ActiveCell.Offset(0, 7) = Tpla ' Tcod2(código empleado+fecha+nº semana9 Tpla (nº semana)
 
    Application.ScreenUpdating = True
CommandButton1_Click
 
    ActiveWorkbook.Save: Unload Me:  Marcaje.Show:
 
Else
 
Cells(fCode2, 2).Select
'Aqui es cuando agregamos o modificamos el registro
   Application.ScreenUpdating = False
    ActiveCell = Tcodigo2
    ActiveCell.Offset(0, 0) = Tnom: ActiveCell.Offset(0, 3) = Lhora
    ActiveCell.Offset(0, 4) = Tfecha: ActiveCell.Offset(0, 5) = Tcod2
    ActiveCell.Offset(0, 6) = Tpla
 
    Application.ScreenUpdating = True
CommandButton1_Click
 
    ActiveWorkbook.Save: Unload Me: Marcaje.Show:
End If '---------------------------------------------------------------------------------------------------3
 
End If '---------------------------------------------------------------------------------------------------1
 
 
 
'**************************************************************************************************************************************************************
End Sub
'---------------------------------------------------------------------------------------------------
 
Private Sub Tcod2_Change()
Cbcode3 = Tcod2
End Sub
 
 
 
Private Sub Tfecha_Change()
Tcodigo2 = Tcod + Tfecha + Tpla
End Sub
 
Private Sub Tnom_Change()
Tnomc = Tnom + " " + Tape 'nombre y apellidos
 
If Tnom <> "" Then
Lhora.Visible = True
Else
Lhora.Visible = False
End If
End Sub
Private Sub Tape_Change()
Tnomc = Tnom + " " + Tape
 
If Tape <> "" Then
Lhora.Visible = True
Else
Lhora.Visible = False
End If
End Sub
 
Private Sub Tnomc_Change()
 
End Sub
 
Private Sub Tpla_Change()
Tcodigo2 = Tcod + Tfecha + Tpla
End Sub
 
Private Sub Truta3_Change() 'esta subrutina es para las fotos de los empleados
If Truta3 <> "" Then
Image1.Picture = LoadPicture(Truta3)
Else
Image1.Picture = LoadPicture(Truta2)
End If
End Sub
 
Private Sub UserForm_Activate() 'Aquí capta la fecha y la hora
    Dim Hor As Byte, Min As Byte
    Hor = Val(Mid(Format(Time, "hh:mm"), 1, 2))
    Min = Val(Mid(Format(Time, "hh:mm"), 4, 2))
    Select Case Min
        Case Is < 7: Min = 0
        Case Is < 22: Min = 15
        Case Is < 37: Min = 30
        Case Is < 52: Min = 45
        Case Is < 59: Min = 0: Hor = Hor + 1
    End Select
    Lhora = TimeValue(Hor & ":" & Min & ":00")
Tpla = weeknum(Tfecha):
Tcod2 = Tcod + Tfecha + Tpla
Lti.Caption = "0:00:00"
 
End Sub
'---------------------------------------------------------------------------------------------------
 
Private Sub UserForm_Initialize() 'Aquí se definen las variables que comente antes que estaban en el evento Initialize
 
Dim rango, celda As Range
Set rango = Worksheets("Empleados").Range("Listado_emp")
 
For Each celda In rango
Cbcode.AddItem celda.Value
 
Next celda
Cbcode.Text = Worksheets("Empleados").Range("A2")
 
Dim rango1, celda1 As Range
Set rango1 = Worksheets("Control").Range("Listado_mar")
 
For Each celda1 In rango1
Cbcode2.AddItem celda1.Value
 
Next celda1
'Cbcode2.Text = Worksheets("Control").Range("A2")
 
'**************************************************************************************
 
Dim rango2, celda2 As Range
Set rango2 = Worksheets("Marcajes").Range("Listado_cod")
 
For Each celda2 In rango2
Cbcode3.AddItem celda2.Value
 
Next celda2
'Cbcode3.Text = Worksheets("Marcajes").Range("A2")
'*************************************************************************************
 
Dim rangoA, celdaA As Range
Set rangoA = Worksheets("recesos").Range("Listado_rec")
 
For Each celdaA In rangoA
Cbreceso.AddItem celdaA.Value
 
Next celdaA
 
'*************************************************************************************
 
Tfecha = Date
Cbcode2.Text = Cbcode.Text
Tcod = ""
End Sub
 
 
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Dim qq As String
If CloseMode = 0 Then
qq = Chr(34): Cancel = 1
End If
End Sub

Libro-control-de-presencia-HOJA-DE-MARCAJES
Control-de-presencia-hoja-de-control
Control-de-presencia-hoja-de-recesos
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Antoni Masana
Val: 1.134
Oro
Ha mantenido su posición en Visual Basic para Aplicaciones (en relación al último mes)
Gráfica de Visual Basic para Aplicaciones

Problema con programa para fichar

Publicado por Antoni Masana (502 intervenciones) el 11/05/2020 20:25:53
Partimos de la base que no se como funcionáis, no se porque haces varios fichajes, no se que son los recesos, tampoco se para que son las hojas: "marcajes", "recesos" y "control".
Tampoco se cuantos fichajes se pueden realizar cada día ni cuanta gente ficha.

Nunca he realizado un proceso de fichajes pero no debe ser muy complicado.

Te voy a contar lo que si se: donde trabajo realizamos fichaje y tenemos varios tipo, Entrada/Salida, E/S Comida, E/S descanso de 10 minutos por ley. E/S Medico, E/S asuntos personales, etc.
Cada tipo tiene un código y van el parejas, si entro a trabajar, tendré que salir, si voy a comer tendré que volver, etc.

¿Por que te cuento esto? pues por que los fichajes van en parejas y a veces falta alguno y hay que insertarlo a mano.
Nosotros somos capaces de fichar al entrar a trabajar e irnos a casa sin volver a fichar. Lo tenemos muy por la mano.

Y todo esto viene a decirte que primero tienes que crear una hoja de fichajes con tres o cuatro datos.
* Fecha del fichaje.
* Hora del fichaje.
* Código del que Ficha.
* Tipo de fichaje (si lo hay).

Y a partir de aquí validas que estén todos los fichajes de cada persona, calcular las horas y dar aviso si falta algún fichaje.
Y partiría de este punto.
Lo que comentaba sobre la cantidad de fichajes es para saber cuando se llenada la hoja y crear algún sistema que se auto gestione solo, por ejemplo una hoja por año.

Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 59
Ha mantenido su posición en Visual Basic para Aplicaciones (en relación al último mes)
Gráfica de Visual Basic para Aplicaciones

Problema con programa para fichar

Publicado por Manuel (26 intervenciones) el 20/05/2020 10:02:19
He hecho una hoja llamada Empleados (donde pongo el código del trabajador, nombre, el sueldo hora, el DNI y el teléfono), otra llamada Marcajes (para la primera entrada y la primera salida), otra para el turno 2 llamada Turno2 para el turno de tarde, (segunda entrada y segunda salida), pero no hay manera de que cuando ficho la tercera vez (entrada del segundo turno) vaya al turno2 (me sobreescribe la entrada del segundo turno en la salida del primer turno) a cada hoja le he puesto un Boton de comando diferente y he creado una variable (para que el programa sepa en que turno esta cada empleado) Codtur = "Tnom" & "2" (donde Tnom es el nombre del empleado) esta variable la creo después de realizar la salida del primer turno.
A continuación del proceso de entrada de código de empleado, que es lo único que tiene que introducir la gente para fichar, He puesto lo siguiente
If Codtur = Tnom & "2" Then 'Aqui es donde manda al Turno2--------2
BTurno2_Click 'manda al Turno2
End If '---------------------------------------------------------------------------------------------------2
No me funciona, no se que he hecho mal ni que hacer para que cuando fichen en el segundo turno marque la fichada en la hoja Turno2, no sobreescriba en la salida de la hoja Marcajes.
A ver si alguien me puede ayudar, Gracias.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Antoni Masana
Val: 1.134
Oro
Ha mantenido su posición en Visual Basic para Aplicaciones (en relación al último mes)
Gráfica de Visual Basic para Aplicaciones

Problema con programa para fichar

Publicado por Antoni Masana (502 intervenciones) el 20/05/2020 16:20:44
No entiendo que pretendes hacer con esto: If Codtur = Tnom & "2"

No se que vale Codtur.
Si Tnom vale "Antonio" el resultado de Tnom & "2" es igual a: "Antonio2"

Sin ver el libro y la macro completa no se donde esta el error.

Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 59
Ha mantenido su posición en Visual Basic para Aplicaciones (en relación al último mes)
Gráfica de Visual Basic para Aplicaciones

Problema con programa para fichar

Publicado por Manuel (26 intervenciones) el 20/05/2020 17:03:47
Codtur es una variable que defino inmediatamente después de fichar la segunda vez (salida del primer turno), la defino como Codtur = Tnom + "2" para que ese trabajador cuando vuelva de comer y vuelva a fichar, el fichaje se anote en la hoja Turno2 y no en la de fichajes (que es para el primer turno), pero no me sirve ya que si vuelve a fichar se escribe como salida en la hoja Marcajes (que es la del primer turno, no se si es que al salir del evento para fichar otra persona se borra y por eso no la reconoce y la premisa Codtur = Tnom & "2" nunca se cumple.
Si intento hacerlo por medio de la hora en la que salen para comer es mas sencillo, pero no podría poner mas de dos turnos y necesito poner mas de dos ya que el horario de los empleados es muy flexible, entran y salen varias veces al dia.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Antoni Masana
Val: 1.134
Oro
Ha mantenido su posición en Visual Basic para Aplicaciones (en relación al último mes)
Gráfica de Visual Basic para Aplicaciones

Problema con programa para fichar

Publicado por Antoni Masana (502 intervenciones) el 20/05/2020 17:29:48
Vamos por partes.
El empleado ficha sin indicar si es entrada o salida ¿Verdad?

El primer fichaje es entrada y el segundo salida.
El tercer fichaje es entrada y el cuarto es salida.
etc.

Fijate que si el número de fichajes es IMPAR es que entra y si es PAR es que sale. Y ahora la gran pregunta ¿Se puede olvidar un fichaje?

Pongo un ejemplo:
Hoy - Pepe - 09:00
Hoy - Pepe - 10:00
Hoy - Pepe - 11:00
Hoy - Pepe - 12:00

¿Que horas son de entrada? Las 9 y las 11 y lo sabemos porque son el 1º y la 3º fichaje.
¿Que horas son de salida? Las 10 y las 12 y lo sabemos porque son el 2º y la 4º fichaje.
¿Donde esta? Fuera

Que pasa si tenemos esto:
Hoy - Pepe - 09:00
Hoy - Pepe - 11:00
Hoy - Pepe - 12:00

¿Que horas son de entrada? Las 9 y las 12 y lo sabemos porque son el 1º y la 3º fichaje.
¿Que horas son de salida? Las 10 y lo sabemos porque son el 2º fichaje.
¿Donde esta? Dentro

Y si no esta donde se supone que esta es que falta un fichaje. Cosa por otra parte que el ordenador no sabe.

Saludos.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 59
Ha mantenido su posición en Visual Basic para Aplicaciones (en relación al último mes)
Gráfica de Visual Basic para Aplicaciones

Problema con programa para fichar

Publicado por Manuel (26 intervenciones) el 20/05/2020 18:01:07
Solo somos 12 personas trabajando y si alguien no ficha me lo comenta y yo me iria a la hoja del turno correspondiente y agregaría manualmente el fichaje que le falta, esto lo verificaría cada dia, solo que no consigo mandar el fichaje del segundo turno a la hoja Turno2, una vez que consiga esto ya podre habilitar mas turnos usando como referencia lo que he hecho en el turno numero 2
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 59
Ha mantenido su posición en Visual Basic para Aplicaciones (en relación al último mes)
Gráfica de Visual Basic para Aplicaciones

Problema con programa para fichar

Publicado por Manuel (26 intervenciones) el 20/05/2020 18:50:05
Como podría hacerlo para que me detectara el nombre y el turno y me pasara a la subrutina del turno2 en vez de a la del primer turno cuando ficharan por segunda vez, me estoy volviendo loco y no se que hacer.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Antoni Masana
Val: 1.134
Oro
Ha mantenido su posición en Visual Basic para Aplicaciones (en relación al último mes)
Gráfica de Visual Basic para Aplicaciones

Problema con programa para fichar

Publicado por Antoni Masana (502 intervenciones) el 21/05/2020 14:26:30
Puedes enviarme el libro para que le de un vistazo.

Creía que te había enviado un mensaje diciendo que sin ver el fichero, como tienes organizada la información y que hacen las macros no puedo ayudarte.
Cuéntame como entra el fichaje y que macros activa, en resumen como funciona o como pretendes que funcione, y te podre decir que hace mal o como mejorarlo.

Si prefieres enviarlo a mi correo: [email protected]

Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 59
Ha mantenido su posición en Visual Basic para Aplicaciones (en relación al último mes)
Gráfica de Visual Basic para Aplicaciones

Problema con programa para fichar

Publicado por Manuel (26 intervenciones) el 21/05/2020 20:18:29
Primero hay un formulario llamado (Principal), donde accedemos al formulario FEmpleados, para registrar un empleado, o al formulario Marcaje donde registramos los marcajes

En el libro hay una hoja que se llama "Empleados", donde se registran mediante un formulario (FEmpleados) el código de empleado (Tcod), un desplegable con todos los codigos de empleado, el nombre (Tnom), el sueldo hora (Tsuh), el DNI (Tdni) y el teléfono (Ttel).
Hay otra hoja denominada "Marcajes" que es para el marcaje del primer turno y otra hoja denominada "Turno1" donde deben ir los marcajes del segundo turno.
El marcaje se realiza introduciendo el código y pulsando ENTER o mediante código de barras.

Esta es la subrutina para introducir el código de empleado y para mandar que inserte los datos en la hoja "Marcajes" (primer turno) o en la hoja "Turno2" (segundo turno).
Después tendría que añadir mas turnos que me hacen falta.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
Private Sub Tcod_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'Esta subrutina se ejecuta cuando ficha el trabajador con su codigo y pulsa enter (Keycode = 13)
 
If KeyCode = 13 Then 'Si pulsamos intro------------------------------------------------------------------- 1
 tcp = Tcod + Tpla 'Tcod es el código empleado y Tpla es el numero de semana
 
'***********************
    If Tnom = "" Then '---------------*
    'TEMPORAL 'Manda a una subrutina (TEMPORAL) que abre un Popup que dice "La lectura fue incorrecta"
   MsgBox_con_Temporizador
    Unload Me
    Exit Sub
    End If '--------------------------*
 
 
 
Dim Hor As Byte, Min As Byte
    Hor = Val(Mid(Format(Time, "hh:mm"), 1, 2))
    Min = Val(Mid(Format(Time, "hh:mm"), 4, 2))
    Select Case Min
        Case Is < 7: Min = 0
        Case Is < 22: Min = 15
        Case Is < 37: Min = 30
        Case Is < 52: Min = 45
        Case Is < 59: Min = 0: Hor = Hor + 1
    End Select
    Lhora.Caption = TimeValue(Hor & ":" & Min & ":00")
 
Dim Hora1 As Variant
 
Hora1 = Format(Lhora, "hh:mm:ss")
 
Select Case Codtur  'Aqui es donde manda al Turno2---------------------------------------------2
    Case Is = Tnom & "2": BTurno2_Click 'manda al Turno2
End Select '-----------------------------------------------------------------------------------2
 
 Codtur = "Tnom" & "2"
 
End If '---------------------------------------------------------------------------------------------------1
 
 
 
'**************************************************************************************************************************************************************
End Sub

Esta es la subrutina del primer marcaje

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
Private Sub CommandButton1_Click()
 
If Tnom = "" Then
Exit Sub
End If
Turno = 1
 
Sheets("Marcajes").Activate
 
Dim fCode3 As Integer '----------------------------------------------------------------------------------------------------------------------------
 
 
fCode3 = nCode3(Tcod2.Text) '                                                                                               Estas líneas son para
 
If fCode3 = 0 Then '                                                                                                                 emplazar la celda
      Do While Not IsEmpty(ActiveCell)
      ActiveCell.Offset(1, 0).Activate ' si el registro no existe, se va al final. '                           donde empezaremos
 Loop
  With ActiveCell.EntireRow.Font '--------------*                                                                        a escribir los datos
    .Name = "Calibri"
    .Size = 9 '                                                                                                                            en la hoja
    End With '------------------------------------*
'------------------------------------------------------------------------------------------------------------------------------------------------------------
 
'Aqui es cuando agregamos o modificamos el registro
    Application.ScreenUpdating = False
    ActiveCell = Tcod2
    ActiveCell.Offset(0, 0) = Tcod2 'Tcod2=Tcod (código empleado)+Tfecha (fecha)+Tpla (numero de semana)
    ActiveCell.Offset(0, 1) = Tnom:  ActiveCell.Offset(0, 2) = Lhora: ' Tnom(nombre empleado) Lhora(hora)
    ActiveCell.Offset(0, 4) = Tfecha:
    ActiveCell.Offset(0, 6) = Tpla
    ActiveCell.Offset(0, 7) = Lti:  'Lti(0:00:00 ya que no ha salido aun)
    ActiveCell.Offset(0, 8) = tcp ' tcp=Tcod( código empleado)+ Tpla (nº semana)
    Application.ScreenUpdating = True
    ActiveWorkbook.Save:  'Unload Me:  Marcaje.Show:
 
 
Else
'If fCode3 <> 0 Then
 
 
Thsa = Lhora: R2 = Lhora
 
CommandButton2_Click ' aquí calcula el tiempo trabajado en el primer turno y asigna el valor de Tti
 
Turno1 = 1
 
Cells(fCode3, 1).Select
'Aqui es cuando agregamos o modificamos el registro
   Application.ScreenUpdating = False
    ActiveCell = Tcod2
    ActiveCell.Offset(0, 3) = Lhora: ActiveCell.Offset(0, 4) = Tfecha
    ActiveCell.Offset(0, 5) = Turno1: ActiveCell.Offset(0, 6) = Tpla
    ActiveCell.Offset(0, 7) = Tti ' Tti (tiempo trabajado en el primer turno)
    ActiveCell.Offset(0, 8) = tcp
 
 
    Application.ScreenUpdating = True
    ActiveWorkbook.Save: ' Unload Me: Marcaje.Show:
 
End If
 
 
End Sub


Esta es la subrutina del segundo turno

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Private Sub BTurno2_Click()
Sheets("Turno2").Activate
Turno = 2
 
Dim Recode As Integer
Recode = Turn2(CbTurno2.Text)
 
If Recode = 0 Then '1'-------------------------------------------------------------------------------------3
      Do While Not IsEmpty(ActiveCell)
      ActiveCell.Offset(1, 0).Activate ' si el registro no existe, se va al final.
      Loop
 
    With ActiveCell.EntireRow.Font '--------------*
    .Name = "Arial"
    .Size = 8
    End With '------------------------------------*
 
 
'Aqui es cuando agregamos o modificamos el registro
    Application.ScreenUpdating = False
    ActiveCell = Tcod2
    ActiveCell.Offset(0, 1) = Tnom:  ActiveCell.Offset(0, 2) = Lhora:
    ActiveCell.Offset(0, 4) = Tfecha
   ' ActiveCell.Offset(0, 5) = Tfecha: ActiveCell.Offset(0, 7) = Tcod2
    ActiveCell.Offset(0, 6) = Tpla
    ActiveCell.Offset(0, 7) = Lti: ActiveCell.Offset(0, 8) = Tcodigo2
    ActiveCell.Offset(0, 9) = tcp
 
    Application.ScreenUpdating = True
    'CommandButton1_Click
    ActiveWorkbook.Save: 'Unload Me:  Marcaje.Show:
 
Else
 
Cells(Recode, 2).Select
'Aqui es cuando agregamos o modificamos el registro
Btiempo_Click ' aquí calcula el tiempo trabajado en el segundo turno y lo asigna a Rti
   Application.ScreenUpdating = False
 
    ActiveCell = Tcod2
    ActiveCell.Offset(0, 0) = Tnom: ActiveCell.Offset(0, 2) = Lhora
    ActiveCell.Offset(0, 3) = Tfecha: ActiveCell.Offset(0, 4) = Turno
    ActiveCell.Offset(0, 5) = Tpla: ActiveCell.Offset(0, 6) = Rti  'Rti (tiempo trabajado en el segundo turno
    ActiveCell.Offset(0, 7) = Tcodigo2: ActiveCell.Offset(0, 8) = tcp
 
    Application.ScreenUpdating = True
 
 
    ActiveWorkbook.Save: 'Unload Me: Marcaje.Show:
End If '---------------------------------------------------------------------------------------------------3
'End If '---------------------------------------------------------------------------------------------------2
 
End Sub

Tambien hay un modulo (modulo1) para controlar las celdas y los rangos que hay en las hojas.
A la hoja "Control" no le hagas caso porque seguramente la voy a eliminar, no me esta sirviendo para nada.
Te envio al correo electrónico que me has dado el excel con el libro y la programación que tengo hasta ahora
Muchas gracias.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 59
Ha mantenido su posición en Visual Basic para Aplicaciones (en relación al último mes)
Gráfica de Visual Basic para Aplicaciones

Problema con programa para fichar

Publicado por Manuel (26 intervenciones) el 22/05/2020 19:07:57
Aun no he podido mandarte el correo desde este ordenador no me deja, problemas con el servidor, lo intentare mañana desde otro ordenador
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 59
Ha mantenido su posición en Visual Basic para Aplicaciones (en relación al último mes)
Gráfica de Visual Basic para Aplicaciones

Problema con programa para fichar

Publicado por Manuel (26 intervenciones) el 23/05/2020 10:54:04
Ya te he mandado el Excel completo dale un vistazo cuando puedas y me comentas si se puede hacer algo, gracias.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
sin imagen de perfil
Val: 59
Ha mantenido su posición en Visual Basic para Aplicaciones (en relación al último mes)
Gráfica de Visual Basic para Aplicaciones

Problema con programa para fichar

Publicado por Manuel (26 intervenciones) el 26/05/2020 19:15:06
Recibiste el excel de fichajes que estoy haciendo?, te lo mandé al correo electrónico que me pusiste, si no lo has recibido me lo comentas para volver a mandártelo.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Antoni Masana
Val: 1.134
Oro
Ha mantenido su posición en Visual Basic para Aplicaciones (en relación al último mes)
Gráfica de Visual Basic para Aplicaciones

Problema con programa para fichar

Publicado por Antoni Masana (502 intervenciones) el 26/05/2020 22:51:11
Lo vi y te conteste o eso creía.

Resulta que después de escribir la respuesta la borre sin haberla enviado, dos puntos para mi.

Te contesto por correo

Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar