Home > Visual Basic > Membuat rumus penilaian dinamis

Membuat rumus penilaian dinamis

September 2, 2010

Setahun yang lalu, sewaktu saya masih aktif mengembangkan aplikasi sekolah di beberapa kabupaten di Riau, masalah yang sering saya hadapi adalah tidak adanya standarisasi rumus dalam menentukan nilai akhir siswa (rapor akhir), tetapi untung saja variabel nilainya masih sama (rata2 tugas, rata2 ulangan, uts dan uas).

Pada awalnya saya hanya menyediakan input prosentasi untuk masing-masing nilai tersebut, dan tentu saja cara ini tidak memberikan solusi yang terbaik mengingat masing-masing guru terkadang mempunyai rumus penilaian yang berbeda.

Jadi alternatif solusi lain yang saya tawarkan adalah dengan memberikan keleluasaan untuk menginputkan sendiri rumus dan untuk melakukan ini kita harus mendefinisikan konstanta untuk mewakili nilai-nilai diatas sebagai berikut :

Contoh untuk mendapatkan nilai akhir dengan rumus :

Nilai Akhir = ((Rata2 tugas + Rata2 ulangan + UTS) / 3 x 0.6) + (UAS x 0.4)

Maka rumus yang harus diinputkan adalah sebagai berikut :

Gimana sampe disini konsepnya sudah jelas bukan, klo iya kita bahas kodenya satu per satu dan untuk menyederhanakan program, nilai dari rata2x tugas, rata2x ulangan, uts dan uas langsung diinputkan via textbox.

Pertama kita desain dulu tampilannya seperti berikut :

kemudian tambahkan fungsi berikut untuk memvalidasi inputan nilai hanya boleh angka.

Private Function validAngka(KeyAscii As Integer) As Integer
    Dim strValid As String

    On Error GoTo errHandle

    strValid = "0123456789."

    If InStr(strValid, Chr(KeyAscii)) = 0 And Not (KeyAscii = vbKeyBack) Then
        validAngka = 0
    Else
        validAngka = KeyAscii
    End If

    Exit Function
errHandle:
    validAngka = 0
End Function

kemudian tinggal panggil dimasing-masing event keypress inputan nilai

Private Sub txtRata2Tugas_KeyPress(KeyAscii As Integer)
    KeyAscii = validAngka(KeyAscii)
End Sub

Private Sub txtRata2Ulangan_KeyPress(KeyAscii As Integer)
    KeyAscii = validAngka(KeyAscii)
End Sub

Private Sub txtUAS_KeyPress(KeyAscii As Integer)
    KeyAscii = validAngka(KeyAscii)
End Sub

Private Sub txtUTS_KeyPress(KeyAscii As Integer)
    KeyAscii = validAngka(KeyAscii)
End Sub

selain memvalidasi inputan nilai kita juga harus memvalidasi inputan rumus penilaian, berikut fungsinya.

Private Function validKarakterRumus(KeyAscii As Integer) As Integer
    Dim strValid As String

    On Error GoTo errHandle

    strValid = "0123456789aArRtTuUsS()<>+*/-. "

    If InStr(strValid, Chr(KeyAscii)) = 0 And Not (KeyAscii = vbKeyBack) Then
        validKarakterRumus = 0
    Else
        validKarakterRumus = KeyAscii
    End If

    Exit Function
errHandle:
    validKarakterRumus = 0
End Function

sama seperti sebelumnya tinggal panggil di event keypress inputan rumus

Private Sub txtRumus_KeyPress(KeyAscii As Integer)
    KeyAscii = Asc(UCase(Chr(KeyAscii))) 'otomatis huruf besar
    KeyAscii = validKarakterRumus(KeyAscii)
End Sub

terakhir untuk tombol Proses akan melakukan pengecekan terhadap rumus yang diinputkan jika oke akan langsung menampilkan hasil nya :

Private Function isValidConst(ByVal value As String) As Boolean
    Dim i           As Integer
    Dim strNotValid As String

    On Error GoTo errHandle

    strNotValid = "aArRtTuUsS" 'karakter konstanta RT, RU, UTS dan UAS

    isValidConst = True
    For i = 1 To Len(value)
        If InStr(1, strNotValid, Mid(value, i, 1)) > 0 Then
            isValidConst = False
            Exit For
        End If
    Next

    Exit Function
errHandle:
    isValidConst = True
End Function

Private Function isValidRumusPenilaian(ByVal rumus As String) As Boolean
    Dim script              As Object
    Dim result              As Long

    Dim strParsing1         As String
    Dim strParsing2         As String
    Dim strFinalParsing     As String

    On Error GoTo errHandle

    strParsing1 = Replace(rumus, " ", "") ' menghapus spasi

    strParsing2 = Replace(strParsing1, "<RT>", 0)
    strParsing2 = Replace(strParsing2, "<RU>", 0)
    strParsing2 = Replace(strParsing2, "<UTS>", 0)
    strParsing2 = Replace(strParsing2, "<UAS>", 0)

    strFinalParsing = Replace(strParsing2, "<", "")

    strFinalParsing = Replace(strFinalParsing, ">", "")
    If Not (Len(strFinalParsing) > 0) Then strFinalParsing = "0"

    'cek klo ada rumus yg tidak sesuai dg konstanta yg sudah didefinisikan, ex : <RT> ditulis <TR>
    If Not isValidConst(strFinalParsing) Then
        isValidRumusPenilaian = False

    Else
        Set script = CreateObject("ScriptControl")
        script.Language = "VBScript"
        result = script.Eval(strFinalParsing)
        Set script = Nothing

        isValidRumusPenilaian = True
    End If

    Exit Function

errHandle:
    isValidRumusPenilaian = False
End Function

Private Function execFormula(ByVal rumus As String) As Single
    Dim script  As Object

    On Error GoTo errHandle

    Set script = CreateObject("ScriptControl")
    script.Language = "VBScript"
    execFormula = script.Eval(rumus)
    Set script = Nothing

    Exit Function
errHandle:
    execFormula = 0
End Function

Private Function getNilaiAkhirByRumus(ByVal rumus As String, ByVal nilaiRT As Single, ByVal nilaiRU As Single, _
                                      ByVal nilaiUTS As Single, ByVal nilaiUAS As Single) As Single

    Dim strParsing1         As String
    Dim strParsing2         As String
    Dim strFinalParsing     As String

    On Error GoTo errHandle

    strParsing1 = Replace(rumus, " ", "") ' menghapus spasi
    strParsing2 = Replace(strParsing1, "<RT>", nilaiRT) ' mengganti const <RT> ke nilai nilaiRT
    strParsing2 = Replace(strParsing2, "<RU>", nilaiRU)  ' mengganti const <RU> ke nilai nilaiRU
    strParsing2 = Replace(strParsing2, "<UTS>", nilaiUTS)  ' mengganti const <UTS> ke nilaiUTS
    strParsing2 = Replace(strParsing2, "<UAS>", nilaiUAS)  ' mengganti const <UAS> ke nilaiUAS

    strFinalParsing = Replace(strParsing2, "<", "")
    strFinalParsing = Replace(strFinalParsing, ">", "")

    If Not (Len(strFinalParsing) > 0) Then strFinalParsing = "0"

    getNilaiAkhirByRumus = FormatNumber(execFormula(strFinalParsing), 0)

    Exit Function

errHandle:
    getNilaiAkhirByRumus = 0
End Function

Private Sub cmdProses_Click()
    If isValidRumusPenilaian(txtRumus.Text) Then
        txtNilaiAkhir.Text = getNilaiAkhirByRumus(txtRumus.Text, Val(txtRata2Tugas.Text), Val(txtRata2Ulangan.Text), Val(txtUTS.Text), Val(txtUAS.Text))

    Else
        MsgBox "Rumus yang Anda inputkan tidak valid", vbExclamation, "Peringatan"
        txtRumus.SetFocus
    End If
End Sub

Selamat MENCOBA🙂

  1. hery
    September 4, 2010 at 7:17 am

    mas gmn cara menghitung pedapatan penjualan perhari, perbulan atau pertahun ???
    dari dan mengetahui piutang maupun hutang???
    dan bagaimana code untuk mengetahui barang apa saja yang paling laku dalam setiap bulannya???

    • September 4, 2010 at 8:35 am

      Yahhhh klo ini mah cuman main2x-an query😀

  2. August 23, 2011 at 2:48 am

    mas mau tanya nh. ane punya database berisikan beberapa tabel. ane cuma pgn dibantuin gimana cara set nilai pada tabel yang ada tulisannya 80%Emax. pokoknya ada tulisannya Emax mas. sedangkan Emax sendiri diperoleh dari pengukuran dan secara otomatis ketika Emax didapat langsung pada cell yang ada pengalinya dengan Emax bisa didapat hasil. dan juga saya mau tanya untuk memberikan hasil OKNG pada kolom result caranya gimana ya mas?. mohon bantuannya.
    ini linknya mas http://www.ziddu.com/download/16145600/filteringtable.rar.html

    • August 24, 2011 at 2:10 am

      Pada saat query menggunakan LIKE om. Contoh :

      SELECT * FROM nama_tabel WHERE nama_field LIKE '%Emax%'
      
      • August 24, 2011 at 3:20 am

        bisa nyoba diprogramin 1 contoh aja g mas di file yang saya upload tuh. plis mas help me……. 1 contoh ja…

        • August 24, 2011 at 4:55 am

          Sory ya om, ngerti sy om alur programnya
          Mendingan langsung om coba aja query diatas, hasilnya akan lebih baik

  3. Yuda
    November 12, 2013 at 10:34 pm

    Mas kalo variablenya dinamis gmn y?ane bingung bgt, nyari logikanya jg g dpt2..mgkn masnya bs bantu ksh masukan?thx

  1. April 16, 2014 at 9:13 am
Comments are closed.
%d bloggers like this: