feio134

Boa noite!Alguém fazia o favor de fazer com que este código conta-se só 8 horas por cada dia util Option Compare Database Option Explicit Public Function DTS(dtInicio As Date, dtFim As Date, Optional HojeTb As Boolean = False, Optional UltTb As Boolean = False) As Integer '.................................................................... ' Nome: DTS ' Entradas: dtInicio As Date ' dtFim As Date ' HojeTb As Boolean ' UltTb As Boolean ' Saída: Integer ' Autor: Arvin Meyer ' Data: Maio 5,2002 ' Comentário: Aceita duas datas e devolve o número de dias úteis ' entre elas. 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. ' Se HojeTb = True, a data inicial também será considerada. ' Se UltTb = true, a data final também será considerada. '.................................................................... On Error GoTo Err_DTS Dim intCount As Integer Dim rst As DAO.Recordset Dim DB As DAO.Database Set DB = CurrentDb Set rst = DB.OpenRecordset("SELECT [FerData] FROM tblFeriados", dbOpenSnapshot) If Not HojeTb Then dtInicio = dtInicio + 1 End If ' Se desejar contar a data de início, passe True em HojeTb intCount = 0 If UltTb Then Do While dtInicio <= dtFim rst.FindFirst "[FerData] = #" & Format(dtInicio, "mm/dd/yyyy") & "#" If Weekday(dtInicio) <> vbSunday And Weekday(dtInicio) <> vbSaturday Then If rst.NoMatch Then intCount = intCount + 1 End If dtInicio = dtInicio + 1 Loop Else Do While dtInicio < dtFim rst.FindFirst "[FerData] = #" & Format(dtInicio, "mm/dd/yyyy") & "#" If Weekday(dtInicio) <> vbSunday And Weekday(dtInicio) <> vbSaturday Then If rst.NoMatch Then intCount = intCount + 1 End If dtInicio = dtInicio + 1 Loop End If DTS = intCount Exit_DTS: Exit Function Err_DTS: Select Case Err Case Else MsgBox Err.Description Resume Exit_DTS End Select End Function '*********** Code End ************** Voltar ao TopoEditar/excluir esta mensagemExcluir esta mensagem

Boa tarde! Desde já os meus parabéns pela vossa disponibilidade para ajudar.Cnsegui este código vba aplicado no exemplo calculaHoras_2009 e faz tempo que ando a procura de algo muito parecido, na realidade este é o que mais se aproxima da solução que procuro, (apenas) precisava que fosse incluída uma pausa para almoço. Tipo entrada 08:00:00, p/Almoço 12:30:00Inicio Período da Tarde 13:30:00, Fim 18:00:00.Bom Fim de Semana e Muito Obrigado Option Compare Database[/background][/size][/font] [font=Arial, Verdana, Tahoma, sans-serif][size=3][background=rgb(247, 247, 247)]Public Function GetElapsedTime(interval) ' fonte Microsoft ' http://support.microsoft.com/kb/210604/pt-br Dim totalhours As Long, totalminutes As Long, totalseconds As _ Long Dim days As Long, hours As Long, minutes As Long, Seconds As Long[/background][/size][/font] [font=Arial, Verdana, Tahoma, sans-serif][size=3][background=rgb(247, 247, 247)]days = Int(CSng(interval)) totalhours = Int(CSng(interval * 24)) totalminutes = Int(CSng(interval * 1440)) totalseconds = Int(CSng(interval * 86400)) hours = totalhours Mod 24 minutes = totalminutes Mod 60 Seconds = totalseconds Mod 60[/background][/size][/font] [font=Arial, Verdana, Tahoma, sans-serif][size=3][background=rgb(247, 247, 247)]GetElapsedTime = days & " Dias " & hours & " Horas " & minutes & _ " Minutos " & Seconds & " Segundos "[/background][/size][/font] [font=Arial, Verdana, Tahoma, sans-serif][size=3][background=rgb(247, 247, 247)]End Function[/background][/size][/font] [font=Arial, Verdana, Tahoma, sans-serif][size=3][background=rgb(247, 247, 247)]Public Function HoraDecimal(dHora As Variant) ''Converte data/hora para formato decimal ''Autor: Carlos Moura - crpmoura@ig.com.br Dim lngDia As Long, intervalo As Double Dim H1 As Long, H2 As Double, dblHora As Double[/background][/size][/font] [font=Arial, Verdana, Tahoma, sans-serif][size=3][background=rgb(247, 247, 247)]If VarType(dHora) < 7 And VarType(dHora) > 5 Then Exit Function intervalo = CDbl(dHora) lngDia = Int(intervalo) H1 = lngDia * 24 dblHora = (intervalo - lngDia) H2 = dblHora * 24 HoraDecimal = Format(H1 + H2, "#0.00") End Function

Boa tarde! Estou a tentar fazer com que o código que vou colar abaixo me de um resultado no formato 00:00:00 em vez de dias como sou um lerdo no vba, não consigo. da pra dar uma ajuda? Obrigado. Option Compare Database Option Explicit Public Function DTS(dtInicio As Date, dtFim As Date, Optional HojeTb As Boolean = False, Optional UltTb As Boolean = False) As Integer '.................................................................... ' Nome: DTS ' Entradas: dtInicio As Date ' dtFim As Date ' HojeTb As Boolean ' UltTb As Boolean ' Saída: Integer ' Autor: Arvin Meyer ' Data: Maio 5,2002 ' Comentário: Aceita duas datas e devolve o número de dias úteis ' entre elas. 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. ' Se HojeTb = True, a data inicial também será considerada. ' Se UltTb = true, a data final também será considerada. '.................................................................... On Error GoTo Err_DTS Dim intCount As Integer Dim rst As DAO.Recordset Dim DB As DAO.Database Set DB = CurrentDb Set rst = DB.OpenRecordset("SELECT [FerData] FROM tblFeriados", dbOpenSnapshot) If Not HojeTb Then dtInicio = dtInicio + 1 End If ' Se desejar contar a data de início, passe True em HojeTb intCount = 0 If UltTb Then Do While dtInicio <= dtFim rst.FindFirst "[FerData] = #" & Format(dtInicio, "mm/dd/yyyy/h/n/s") & "#" If Weekday(dtInicio) <> vbSunday And Weekday(dtInicio) <> vbSaturday Then If rst.NoMatch Then intCount = intCount + 1 End If dtInicio = dtInicio + 1 Loop Else Do While dtInicio < dtFim rst.FindFirst "[FerData] = #" & Format(dtInicio, "mm/dd/yyyy/h/n/s") & "#" If Weekday(dtInicio) <> vbSunday And Weekday(dtInicio) <> vbSaturday Then If rst.NoMatch Then intCount = intCount + 1 End If dtInicio = dtInicio + 1 Loop End If DTS = intCount Exit_DTS: Exit Function Err_DTS: Select Case Err Case Else MsgBox Err.Description Resume Exit_DTS End Select End Function '*********** Code End **************