Visual Basic para Aplicaciones - Problema con programa para fichar

Life is soft - evento anual de software empresarial

Pos: 12

Val: 59

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:

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 clara

No me gusta: Está pregunta no esta clara o no es útil

Responder

Pos: 1

Val: 1.134

Problema con programa para fichar

Publicado por Antoni Masana (498 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.

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 clara

No me gusta: Está respuesta no esta clara o no es útil

Comentar

Pos: 12

Val: 59

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:

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

Valora esta respuesta

Comentar

Pos: 1

Val: 1.134

Problema con programa para fichar

Publicado por Antoni Masana (498 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

Comentar

Pos: 12

Val: 59

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

Comentar

Pos: 1

Val: 1.134

Problema con programa para fichar

Publicado por Antoni Masana (498 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

Comentar

Pos: 12

Val: 59

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

Comentar

Pos: 1

Val: 1.134

Problema con programa para fichar

Publicado por Antoni Masana (498 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

Comentar

Pos: 12

Val: 59

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

Comentar

Pos: 12

Val: 59

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

Comentar

Pos: 1

Val: 1.134

Problema con programa para fichar

Publicado por Antoni Masana (498 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

Comentar

Pos: 12

Val: 59

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.

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

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

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

Comentar

Pos: 12

Val: 59

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

Comentar

Pos: 12

Val: 59

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

Comentar

Pos: 12

Val: 59

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

Comentar

Pos: 1

Val: 1.134

Problema con programa para fichar

Publicado por Antoni Masana (498 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

Comentar

vba - excel macro para insertar nuevos datos a una planilla en el lugar correcto

Cómo Integrar Autogenerador de Claves para Guardar Datos Excel