Kezdjük az off-al: A 8. sorod hibás, mert az az 1 perc még 7 óra előtt volt, ezért a helyes érték 0, a 10. sorban meg 44.34 a helyes érték.
De a lényeg, hogy megcsináltam, amit kértél. Az eredményeket kénytelen voltam stringgé formázni (tehát nem tudsz számolni velük). Ugyanis, nem tudtam olyan formázást találni, hogy idő formátum kerüljön a táblázatba akkor is, ha az órák száma 24 fölé megy. Tehát a 36:01 helyett 12:01-et mutatott, és a szerkesztőlécen pedig 1900.01.02 12:01 jelent meg. Ha valaki tudna segíteni, hogyan lehetne ezt kiküszöbölni, az jó lenne.
A program végigmegy a táblázaton. Az esetleges üres sorokat kihagyja (üresnek tekinti azt, ahol a kezdő és a befejező dátum üres)
Ha csak a kezdő, vagy a befejező dátum hiányzik, akkor erre a program figyelmeztet, és az adott sort átugorja. Ugyancsak figyelmeztet, ha a kezdő és befejező dátum azonos.
Ha a kezdő és befejező dátum fel lett cserélve, akkor a figyelmeztetésen kívül be is írja ezt a tényt az adott sorban a munkaidő (C) oszlopba
Igyekeztem tesztelni a programot szélsőséges esetekkel is, egyelőre nem találtam hibát, de azért egy darabig ellenőrizd magad is, nem maradt-e benne véletlenül poloska.
Végül mindenkitől elnézést kérek, hogy ilyen hosszú programot másolok be ide. Ha még módosulna, azt majd a data.hu-oldalra másolom. És akkor a program:
Sub munkaórák()
Const forrásoszlop1 As String = "A", forrásoszlop2 As String = "B", céloszlop As String = "C"
Const kezdőóra As Integer = 7, végóra As Integer = 19
Dim üresdátum As Date, dátum1 As Date, év1 As Integer, hó1 As Integer, nap1 As Integer, óra1 As Integer, perc1 As Integer
Dim dátum2 As Date, év2 As Integer, hó2 As Integer, nap2 As Integer, óra2 As Integer, perc2 As Integer
Dim aktsor As Integer, céloszlopszám As Integer
Dim elsőnapióra As Integer, utolsónapióra As Integer, elsőnapiperc As Integer, utolsónapiperc As Integer, _
köztesnapióra As Integer, összesóra As Integer, összesperc As Integer, eredmstring As String
Dim utolsósor As Long
utolsósor = ActiveCell.SpecialCells(xlLastCell).Row
For aktsor = 1 To utolsósor
céloszlopszám = oszlopszám(céloszlop)
Cells(aktsor, céloszlopszám).Select
dátum1 = Cells(aktsor, oszlopszám(forrásoszlop1))
dátum2 = Cells(aktsor, oszlopszám(forrásoszlop2))
If dátum1 = üresdátum And dátum2 = üresdátum Then ' ha üres mindkét dátum
GoTo ciklusvége ' akkor tovább
ElseIf dátum1 = üresdátum Or dátum2 = üresdátum Then ' ha csak az egyik üres
If dátum1 = üresdátum Then
MsgBox "A kezdő időpont hiányzik!"
Else
MsgBox "A befejező időpont hiányzik!"
End If
GoTo ciklusvége
ElseIf dátum2 < dátum1 Then ' némi védelem hibás adat ellen
MsgBox "Hibás dátumok. A második kisebb, mint az első!"
Cells(aktsor, céloszlopszám) = "Hibás dátumok. A második kisebb, mint az első"
GoTo ciklusvége
ElseIf dátum2 = dátum1 Then ' Ha azonosak, akkor 0 óra telt el
Cells(aktsor, céloszlopszám) = 0
MsgBox "A kezdő és befejező időpont azonos!"
GoTo ciklusvége
End If
év1 = Year(dátum1)
hó1 = Month(dátum1)
nap1 = Day(dátum1)
óra1 = Hour(dátum1)
perc1 = Minute(dátum1)
elsőnapióra = 0
elsőnapiperc = 0
If óra1 < kezdőóra Then
elsőnapióra = végóra - kezdőóra ' Ha 7 előtt kezdett, akkor ez teljes napnak számít
Else
If óra1 < végóra Then
elsőnapióra = végóra - óra1 ' Ha 19 óra előtt kezdett, akkor ennyi az értékes órák száma, egyébként 0
If perc1 > 0 Then
elsőnapióra = elsőnapióra - 1
elsőnapiperc = 60 - perc1
End If
End If
End If
óra1 = 0
perc1 = 0
dátum1 = CDate(Str(év1) + "." + Str(hó1) + "." + Str(nap1) + Str(óra1) + ":" + Str(perc1)) + 1 ' A következő nap
év2 = Year(dátum2)
hó2 = Month(dátum2)
nap2 = Day(dátum2)
óra2 = Hour(dátum2)
perc2 = Minute(dátum2)
utolsónapióra = 0
utolsónapiperc = 0
If óra2 > végóra Then
utolsónapióra = végóra - kezdőóra ' Ha 19 óra után végzett, akkor ez teljes napnak számít
Else
If óra2 > kezdőóra Then
utolsónapióra = óra2 - kezdőóra ' Ha 7 után végzett, akkor ennyi az értékes órák száma, egyébként 0
If perc2 > 0 Then
utolsónapiperc = perc2
End If
End If
End If
óra2 = 0
perc2 = 0
dátum2 = CDate(Str(év2) + "." + Str(hó2) + "." + Str(nap2) + Str(óra2) + ":" + Str(perc2)) ' Ez az előző nap végének felel meg
köztesnapióra = (dátum2 - dátum1) * (végóra - kezdőóra)
összesóra = elsőnapióra + utolsónapióra + köztesnapióra
összesperc = elsőnapiperc + utolsónapiperc
If összesperc > 60 Then
összesperc = összesperc - 60
összesóra = összesóra + 1
End If
eredmstring = Format(LTrim(Str(összesóra)), "0") + ":" + Format(LTrim(Str(összesperc)), "00")
Cells(aktsor, céloszlopszám).NumberFormat = "@" ' ezzel lesz string a cellaformátum, másképp elrontja a kiírási formátumot
Cells(aktsor, céloszlopszám).HorizontalAlignment = xlRight ' és jobbra pozícionáljuk
Cells(aktsor, céloszlopszám) = eredmstring
ciklusvége:
Next
Cells(aktsor, céloszlopszám).Select ' Végül az első üres sorra állunk
End Sub
Function oszlopszám(oszlopnév As String) As Integer ' Oszlopnévből oszlopszám kiírás
Dim első As Integer
Dim második As Integer
oszlopszám = 0
If Len(oszlopnév) = 1 Then
oszlopszám = InStr(1, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", oszlopnév)
ElseIf Len(oszlopnév) = 2 Then
első = InStr(1, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", Left(oszlopnév, 1))
második = InStr(1, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", Mid(oszlopnév, 2, 1))
If első > 0 And második > 0 Then ' Csak ha mindkettő érvényes
oszlopszám = első * 26 + második
End If
End If
If oszlopszám = 0 Then
MsgBox "Programhiba: Hibás konstans oszlopnév: " + oszlopnév
End If
End Function
