Fazer com que código funcione no Excel
Enviado: 25 Mar 2016 às 15:25
A todo o Pessoal do do Fórum um bom dia, um bom fim de semana Prolongado!
O que me leva a novamente estar a chatear-vos é o seguinte, tenho um código que está num ficheiro access e que precisava colocar a funcionar no Excel.
Dava para dar uma ajuda? desde já um muito obrigado e um bom fim de semana de Páscoa.
O que me leva a novamente estar a chatear-vos é o seguinte, tenho um código que está num ficheiro access e que precisava colocar a funcionar no Excel.
Dava para dar uma ajuda? desde já um muito obrigado e um bom fim de semana de Páscoa.
Código: Selecionar todos
Option Explicit
Public Function DuracaoTarefa(dtInicio As Date, dtFim As Date) As Integer
'....................................................................
' Nome: DuracaoTarefa
' Entradas: dtInicio As Date
' dtFim As Date
' Saída: Integer (Minutos)
' Autor: Arvin Meyer
' Data: Maio 5,2002
' Comentário:
' Aceita duas datas e devolve o número de minutos entre elas. Tem conta
' o horário definido na tabela "tblHorario".
' O horário é definido em 3 períodos. O inicio/fim de cada período é
' definido com o número de minutos desde as 0 horas.
' Note-se que esta função considera os feriados do período. Ela exige a
' existência de uma tabela chamada "tblFeriados" com um campo, no formato
' data, chamado FerData. Os Domingos também são ignorados.
'....................................................................
On Error GoTo Err_DuracaoTarefa
Dim intCount As Integer
Dim DB As DAO.Database
Dim rst As DAO.Recordset
Dim rst_horario As DAO.Recordset
Dim TotalMinutos
Dim TotalMinutosFora
Dim MinutoAtual
Dim P1I, P1F
Dim P2I, P2F
Dim P3I, P3F
Dim DiaAtual As Date
Dim MinutoInicial As Integer
Dim MinutoFinal As Integer
TotalMinutos = 0
DiaAtual = dtInicio
Set DB = CurrentDb
Set rst = DB.OpenRecordset("SELECT [FerData] FROM tblFeriados", dbOpenSnapshot)
intCount = 0
Do While DiaAtual < dtFim
rst.FindFirst "[FerData] = #" & Format(DiaAtual, "mm/dd/yyyy") & "#"
If Weekday(DiaAtual) <> vbSunday Then '' And Weekday(dtInicio) <> vbSaturday Then
If rst.NoMatch Then
'Se chegou aqui é porque é dia útil e não é feriado
Set rst_horario = DB.OpenRecordset("SELECT * FROM tblHorario where HorarioDiaSemanaNum = " & Weekday(DiaAtual), dbOpenSnapshot)
P1I = rst_horario("HorarioP1Inicio")
P1F = rst_horario("HorarioP1Fim")
P2I = rst_horario("HorarioP2Inicio")
P2F = rst_horario("HorarioP2Fim")
P3I = rst_horario("HorarioP3Inicio")
P3F = rst_horario("HorarioP3Fim")
If Day(dtFim) = Day(dtInicio) And dtFim - dtInicio < 24 Then ' Inicia e termina no mesmo dia
MinutoInicial = Hour(dtInicio) * 60 + Minute(dtInicio)
MinutoFinal = Hour(dtFim) * 60 + Minute(dtFim)
For MinutoAtual = MinutoInicial To MinutoFinal
If (MinutoAtual >= P1I And MinutoAtual < P1F) Then 'Periodo 1
TotalMinutos = TotalMinutos + 1
ElseIf (MinutoAtual >= P2I And MinutoAtual < P2F) Then 'Periodo 2
TotalMinutos = TotalMinutos + 1
ElseIf (MinutoAtual >= P3I And MinutoAtual < P3F) Then 'Periodo 3
TotalMinutos = TotalMinutos + 1
Else
TotalMinutosFora = TotalMinutosFora + 1
End If
Next
ElseIf DiaAtual = dtInicio Then 'Tratamento 1º dia
MinutoInicial = Hour(dtInicio) * 60 + Minute(dtInicio)
MinutoFinal = 1440
For MinutoAtual = MinutoInicial To MinutoFinal - 1
If (MinutoAtual >= P1I And MinutoAtual < P1F) Then 'Periodo 1
TotalMinutos = TotalMinutos + 1
ElseIf (MinutoAtual >= P2I And MinutoAtual < P2F) Then 'Periodo 2
TotalMinutos = TotalMinutos + 1
ElseIf (MinutoAtual >= P3I And MinutoAtual < P3F) Then 'Periodo 3
TotalMinutos = TotalMinutos + 1
Else
TotalMinutosFora = TotalMinutosFora + 1
End If
Next
ElseIf Day(DiaAtual) = Day(dtFim) And dtFim - DiaAtual < 24 Then 'Tratamento último dia
MinutoInicial = 0
MinutoFinal = Hour(dtFim) * 60 + Minute(dtFim)
For MinutoAtual = MinutoInicial To MinutoFinal - 1
If (MinutoAtual >= P1I And MinutoAtual < P1F) Then 'Periodo 1
TotalMinutos = TotalMinutos + 1
ElseIf (MinutoAtual >= P2I And MinutoAtual < P2F) Then 'Periodo 2
TotalMinutos = TotalMinutos + 1
ElseIf (MinutoAtual >= P3I And MinutoAtual < P3F) Then 'Periodo 3
TotalMinutos = TotalMinutos + 1
Else
TotalMinutosFora = TotalMinutosFora + 1
End If
Next
ElseIf DiaAtual > dtInicio And DiaAtual < dtFim Then
For MinutoAtual = 0 To 1440
If (MinutoAtual >= P1I And MinutoAtual < P1F) Then 'Periodo 1
TotalMinutos = TotalMinutos + 1
ElseIf (MinutoAtual >= P2I And MinutoAtual < P2F) Then 'Periodo 2
TotalMinutos = TotalMinutos + 1
ElseIf (MinutoAtual >= P3I And MinutoAtual < P3F) Then 'Periodo 3
TotalMinutos = TotalMinutos + 1
Else
TotalMinutosFora = TotalMinutosFora + 1
End If
Next
Else
End If
'intCount = intCount + 1
Else
End If
End If
DiaAtual = DiaAtual + 1
Loop
DuracaoTarefa = TotalMinutos
Exit_DuracaoTarefa:
Exit Function
Err_DuracaoTarefa:
Select Case Err
Case Else
MsgBox Err.Description
Resume Exit_DuracaoTarefa
End Select
End Function