ysh pak kid & XL-mania members..
terima kasih kiriman solusinya; saat ini sedang dicoba-coba
maklum soal makro adalah hal yg sama sekali baru bagi kami
walalupun contoh dari kami mengandung kesalahan, rupanya pak kid
sudah memakluminya.
ini sekalian kami susulkan contoh data yg sudah diperbaiki
rupanya ada kesalahan penanggalan kami,
sehingga yg dianggap hari bukan hari kerja
hanya hari sabtu, hari minggu malah = hari kerja
sekali lagi : terima kasih XL-mania....
On 9/24/09, kid <nmkid.family@gmail.com > wrote:
>
> Dear HerrSoe,
>
> Listing code berikut adalah listing versi beta. Seingat saya, ada sedikit perubahan supaya lebih tepat (alias versi ini masih ada sedikit error hasil perhitungan). Tapi gampang kok mengubahnya. Moga-moga temen-temen ada yang bersedia memperbaikinya. (udah lama nggak dioprek dan digunakan)
>
> Nah fungsi ini digunakan layaknya fungsi-fungsi pada formula biasanya.
> Cukup letakkan pada sebuah module VBA.
>
> Cara pakai :
> Misal di Cell A2 adalah tanggal awal
> B2 adalah jumlah hari kerja kedepan (+) atau kebelakang (-)
> Z1 sampai Z25 adalah daftar tanggal libur nasional, dan libur yang ditetapkan perusahaan.
> Libur rutin untuk pegawai di baris 2 ini adalah Minggu (hari ke 1), Rabu (hari ke 4), dan Jumat (hari ke 6),
> maka di C2 ada teks 1,4,6
>
> Maka hasil di D2 :
> =FirstWorkday(A2, B2, Z1:Z25, C2)
>
> 'Kid - 12-06-1999
> Public Function FirstWorkday(dblFirstDate As Date, _
> Optional dblDays As Double = 0, _
> Optional vHolidays As Variant = 0, _
> Optional sRutin As String = vbNullString) As Variant
> Dim lStart As Long
> Dim lDays As Long
> Dim lFact As Long
> Dim vHol As Variant
> Dim vTmp As Variant
> Dim sCust() As String
> Dim lCust() As Long
> Dim bCust As Boolean
> Dim lRes As Long
> Dim lTmp As Long
> Dim bHol As Boolean
>
> On Error GoTo ErrResult
> lStart = CLng(WorksheetFunction.RoundDown(CDbl(dblFirstDate), 0))
>
> If dblDays < 0 Then
> lFact = -1
> lDays = CLng(WorksheetFunction.RoundDown(-dblDays, 0))
> Else
> lFact = 1
> lDays = CLng(WorksheetFunction.RoundDown(dblDays, 0))
> End If
>
> vHol = vHolidays
> If IsArray(vHol) Then
> vTmp = vHol
> Else
> ReDim vTmp(1 To 1, 1 To 1)
> vTmp(1, 1) = vHol
> End If
>
> bCust = False
> If LenB(sRutin) <> 0 Then
> sCust() = Split(sRutin, ",")
> lTmp = UBound(sCust)
> If lTmp > 5 Then 'start dari 0, maka 5 = hari ke enam
> 'karena jika libur rutin lebih dari 6 hari = libur terus
> GoTo ErrResult
> End If
>
> ReDim lCust(lTmp)
> For lRes = 0 To lTmp
> If IsNumeric(sCust(lRes)) Then
> bCust = True
> lCust(lRes) = CLng(sCust(lRes))
> Else
> bCust = False
> Exit For
> End If
> Next
> If Not bCust Then
> GoTo ErrResult
> End If
> Else
> ReDim lCust(1)
> lCust(0) = 1
> lCust(1) = 7
> End If
>
> lRes = lStart
> lTmp = 0
>
> Do
> bHol = False
> 'cek di daftar libur khusus
> For Each vHol In vTmp
> If lStart = vHol Then
> bHol = True
> 'lDays = lDays + 1
> Exit For
> End If
> Next
>
> 'cek didaftar libur rutin
> If Not bHol Then
> For Each vHol In lCust
> If Weekday(CDate(lStart)) = vHol Then
> bHol = True
> Exit For
> End If
> Next
> End If
>
> 'set result as new workday
> If Not bHol Then
> lRes = lStart
> lTmp = lTmp + 1
> End If
> lStart = lStart + lFact
> Loop Until lTmp > lDays
>
> If lRes < 61 Then
> GoTo ErrResult
> ElseIf lRes > 2958465 Then
> GoTo ErrResult
> Else
> FirstWorkday = lRes
> End If
>
> Exit Function
> ErrResult:
> FirstWorkday = CVErr(xlErrNum) '"#ERR := #NUM!"
> End Function
>
> Semoga bermanfaat.
> Kid.
>
> Dear HerrSoe,
>
> Listing code berikut adalah listing versi beta. Seingat saya, ada sedikit perubahan supaya lebih tepat (alias versi ini masih ada sedikit error hasil perhitungan)
>
> Nah fungsi ini digunakan layaknya fungsi-fungsi pada formula biasanya.
> Cukup letakkan pada sebuah module VBA.
>
> Cara pakai :
> Misal di Cell A2 adalah tanggal awal
> B2 adalah jumlah hari kerja kedepan (+) atau kebelakang (-)
> Z1 sampai Z25 adalah daftar tanggal libur nasional, dan libur yang ditetapkan perusahaan.
> Libur rutin untuk pegawai di baris 2 ini adalah Minggu (hari ke 1), Rabu (hari ke 4), dan Jumat (hari ke 6),
> maka di C2 ada teks 1,4,6
>
> Maka hasil di D2 :
> =FirstWorkday(
>
> 'Kid - 12-06-1999
> Public Function FirstWorkday(
> Optional dblDays As Double = 0, _
> Optional vHolidays As Variant = 0, _
> Optional sRutin As String = vbNullString) As Variant
> Dim lStart As Long
> Dim lDays As Long
> Dim lFact As Long
> Dim vHol As Variant
> Dim vTmp As Variant
> Dim sCust() As String
> Dim lCust() As Long
> Dim bCust As Boolean
> Dim lRes As Long
> Dim lTmp As Long
> Dim bHol As Boolean
>
> On Error GoTo ErrResult
> lStart = CLng(WorksheetFunct
>
> If dblDays < 0 Then
> lFact = -1
> lDays = CLng(WorksheetFunct
> Else
> lFact = 1
> lDays = CLng(WorksheetFunct
> End If
>
> vHol = vHolidays
> If IsArray(vHol) Then
> vTmp = vHol
> Else
> ReDim vTmp(1 To 1, 1 To 1)
> vTmp(1, 1) = vHol
> End If
>
> bCust = False
> If LenB(sRutin) <> 0 Then
> sCust() = Split(sRutin, ",")
> lTmp = UBound(sCust)
> If lTmp > 5 Then 'start dari 0, maka 5 = hari ke enam
> 'karena jika libur rutin lebih dari 6 hari = libur terus
> GoTo ErrResult
> End If
>
> ReDim lCust(lTmp)
> For lRes = 0 To lTmp
> If IsNumeric(sCust(
> bCust = True
> lCust(lRes) = CLng(sCust(lRes)
> Else
> bCust = False
> Exit For
> End If
> Next
> If Not bCust Then
> GoTo ErrResult
> End If
> Else
> ReDim lCust(1)
> lCust(0) = 1
> lCust(1) = 7
> End If
>
> lRes = lStart
> lTmp = 0
>
> Do
> bHol = False
> 'cek di daftar libur khusus
> For Each vHol In vTmp
> If lStart = vHol Then
> bHol = True
> 'lDays = lDays + 1
> Exit For
> End If
> Next
>
> 'cek didaftar libur rutin
> If Not bHol Then
> For Each vHol In lCust
> If Weekday(CDate(
> bHol = True
> Exit For
> End If
> Next
> End If
>
> 'set result as new workday
> If Not bHol Then
> lRes = lStart
> lTmp = lTmp + 1
> End If
> lStart = lStart + lFact
> Loop Until lTmp > lDays
>
> If lRes < 61 Then
> GoTo ErrResult
> ElseIf lRes > 2958465 Then
> GoTo ErrResult
> Else
> FirstWorkday = lRes
> End If
>
> Exit Function
> ErrResult:
> FirstWorkday = CVErr(xlErrNum) '"#ERR := #NUM!"
> End Function
>
> Semoga bermanfaat.
> Kid.
__._,_.___
+-:: XL-mania ::::::::::::::::::::----------------------------------+
| Selamat Idul Fitri... Mohon maap dari momods... |
| http://www.facebook.com/group.php?gid=37671048001&ref=mf |
+-------------------------------------------------------------------+
| DILARANG : MLM, money game, OOT, iklan tanpa izin, SARA, testing, |
| pembicaraan pribadi, one line message, melecehkan, tidak sopan. |
+-------------------------------------------------------------------+
| Buat subjek yang kreatif, jangan : "tanya", "help", "mohon bantu" |
| Usahakan besar attachment < 200 kb. Gunakan winzip jika perlu. |
+-------------------------------------------------------------------+
| Ajak teman-teman Anda bergabung dengan mengirim e-mail kosong ke |
| XL-mania-subscribe@yahoogroups.com atau kirimkan mereka file dari |
| http://groups.yahoo.com/group/XL-mania/files/Promotion/ |
+-------------------------------------------------------------------+
| Berikan testimoni di : http://www.friendster.com/xlmania atau... |
| http://www.xl-mania.com/2008/06/testimoni-xl-mania.html |
+-------------------------------------------------------------------+
| Message lama ada di : |
| http://groups.yahoo.com/group/XL-mania/messages [perlu yahoo id] |
| http://www.mail-archive.com/xl-mania@yahoogroups.com |
+-------------------------------------------------------------------+
| Selamat Idul Fitri... Mohon maap dari momods... |
| http://www.facebook.com/group.php?gid=37671048001&ref=mf |
+-------------------------------------------------------------------+
| DILARANG : MLM, money game, OOT, iklan tanpa izin, SARA, testing, |
| pembicaraan pribadi, one line message, melecehkan, tidak sopan. |
+-------------------------------------------------------------------+
| Buat subjek yang kreatif, jangan : "tanya", "help", "mohon bantu" |
| Usahakan besar attachment < 200 kb. Gunakan winzip jika perlu. |
+-------------------------------------------------------------------+
| Ajak teman-teman Anda bergabung dengan mengirim e-mail kosong ke |
| XL-mania-subscribe@yahoogroups.com atau kirimkan mereka file dari |
| http://groups.yahoo.com/group/XL-mania/files/Promotion/ |
+-------------------------------------------------------------------+
| Berikan testimoni di : http://www.friendster.com/xlmania atau... |
| http://www.xl-mania.com/2008/06/testimoni-xl-mania.html |
+-------------------------------------------------------------------+
| Message lama ada di : |
| http://groups.yahoo.com/group/XL-mania/messages [perlu yahoo id] |
| http://www.mail-archive.com/xl-mania@yahoogroups.com |
+-------------------------------------------------------------------+
Change settings via the Web (Yahoo! ID required)
Change settings via email: Switch delivery to Daily Digest | Switch format to Traditional
Visit Your Group | Yahoo! Groups Terms of Use | Unsubscribe
.
__,_._,___
Nenhum comentário:
Postar um comentário