Scribd
Upload
24 views12 pages

Kodingnya

The document contains code for a lottery application built in VBA for Excel, featuring user forms for managing participants, prizes, and winners. It includes functionalities for adding, editing, and deleting entries, as well as selecting random winners based on user-defined criteria. The application also allows users to save and clear data, and provides visual feedback during the lottery process.

Uploaded by

ramax.sakti2
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as DOCX, PDF, TXT or read online on Scribd
24 views12 pages

Kodingnya

The document contains code for a lottery application built in VBA for Excel, featuring user forms for managing participants, prizes, and winners. It includes functionalities for adding, editing, and deleting entries, as well as selecting random winners based on user-defined criteria. The application also allows users to save and clear data, and provides visual feedback during the lottery process.

Uploaded by

ramax.sakti2
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as DOCX, PDF, TXT or read online on Scribd
You are on page 1/ 12

FORM UTAMA

‘Jika pc/laptop sobat menggunakan windows 32bit maka hilangkan kode “PtrSafe” nya agar tidak error’

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'this is so that we
can use the Sleep _

Dim ws As Worksheet

Private Sub cmdKeluar_Click()

Unload Me

Application.Quit

ActiveWorkbook.Close savechanges:=False

End Sub

Private Sub Label2_Click()

Application.Visible = True

UTAMA.Hide

End Sub

Private Sub UserForm_Initialize()

HideCloseButton Me

With Me.cmbTime

.AddItem ("3")

.AddItem ("6")

.AddItem ("9")

.AddItem ("12")

.AddItem ("15")

End With

Me.cmbTime.Value = "3"

Call listhadiah

Me.ListBox1.Height = 102

End Sub

Private Sub cmbHadiah_Change()

On Error Resume Next

Set sh = Sheets("Hadiah")

cari = Me.cmbHadiah.Value

With sh.Range("b:b")

Set hadiahnya = .Find(cari, LookIn:=xlValues)

If Not hadiahnya Is Nothing Then

baris = hadiahnya.Row

Me.lblNamaHadiah.Caption = sh.Cells(baris, 3).Value


Image1.Picture = LoadPicture(sh.Cells(baris, 4).Value)

End If

End With

End Sub

Private Sub cmdHadiah_Click()

HADIAH.Show

End Sub

Private Sub cmdPeserta_Click()

PESERTA.Show

End Sub

Private Sub cmdReset_Click()

Set ws = Worksheets("Pemenang")

akhir = ws.Cells(Rows.Count, 3).End(xlUp).Row

If MsgBox("Anda Yakin Akan Menghapus Data Pemenang Undian?", vbYesNo + vbCritical, "APLIKASI
UNDIAN") = vbYes Then

If ws.Range("C4") = "" Then

Exit Sub

Else

ws.Range("a4:h" & akhir).ClearContents

End If

Else

Exit Sub

End If

ThisWorkbook.Save

End Sub

Private Sub cmdSimpan_Click()

Dim region As String

Dim selection As Variant

Sheets("Pemenang").Copy

selection = Application.GetSaveAsFilename( _

FileFilter:="Excel Workbook (*.xlsx), *.xlsx", _

Title:="Please Select Location to Save File", _

InitialFileName:="Pemenang Undian " & " " & _

Format(Date, "dd-mm-yyyy"))
If selection <> False Then

ActiveWorkbook.SaveAs Filename:=selection

End If

ActiveWorkbook.Close savechanges:=False

Application.Visible = False

End Sub

Private Sub cmdStart_Click()

On Error Resume Next

If Me.cmbHadiah.Value = "" Then

MsgBox "Masukkan Dulu Hadiah Yang Akan Diundi", vbOKOnly + vbExclamation, "APLIKASI UNDIAN"

Exit Sub

Else

Sheets("Peserta").Select

Me.txtPemenang.Caption = ""

Me.lblPemenang.Caption = ""

Me.Label5.Visible = True

Me.Label6.Visible = True

Me.Label7.Visible = True

Label5.Caption = ChrW(9679)

Label6.Caption = ChrW(9679)

Label7.Caption = ChrW(9679)

dg = RGB(64, 64, 64)

wh = RGB(255, 255, 255)

'9679

t=0

Do Until t = Me.cmbTime.Value - 2 ' will run for 6 seconds

Label5.ForeColor = wh

DoEvents

Sleep 500

Label5.ForeColor = dg

Label6.ForeColor = wh

DoEvents

Sleep 500

Label6.ForeColor = dg

Label7.ForeColor = wh
DoEvents

Sleep 500

Label7.ForeColor = dg

t=t+1

Loop

Me.Label5.Visible = False

Me.Label6.Visible = False

Me.Label7.Visible = False

Dim xRow As Long

If Sheets("Peserta").Range("b4").Value = "" Or _

Sheets("Peserta").Range("c4").Value = "" Then

MsgBox "Periksa Kembali Data Peserta Anda", vbOKOnly + vbCritical, "APLIKASI UNDIAN"

Exit Sub

Else

xNames = Application.CountA(Range("B:B")) - 3

xRow = Application.RandBetween(4, xNames + 3)

Me.txtPemenang.Caption = Cells(xRow, 3)

Me.lblPemenang = Cells(xRow, 2)

Call menang

Call tampil

Call hapusjikamenang

Me.cmbHadiah.Value = ""

End If

End If

ThisWorkbook.Save

End Sub

Private Sub CommandButton1_Click()

PEMENANG.Show

End Sub

Private Sub UserForm_Activate()

Set ws = Sheets("Pemenang")

ws.Activate

ibow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(0, 0).Row

ListBox1.RowSource = "a4:h" & ibow + 1

End Sub
Sub menang()

Dim ws As Worksheet, ws1 As Worksheet

Set ws = Worksheets("Peserta")

Set ws1 = Worksheets("Pemenang")

akhir1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row

cari = Me.lblPemenang.Caption

With ws.Range("b:b")

Set pemenangnya = .Find(cari, LookIn:=xlValues)

If Not pemenangnya Is Nothing Then

baris = pemenangnya.Row

ws1.Range("a" & akhir1 + 1).Value = "=Row()-3"

ws1.Range("b" & akhir1 + 1).Value = "'" & Format(Now, "dd-MMM-yyyy")

ws1.Range("c" & akhir1 + 1).Value = Me.cmbHadiah.Value

ws1.Range("d" & akhir1 + 1).Value = ws.Cells(baris, 2).Value

ws1.Range("e" & akhir1 + 1).Value = ws.Cells(baris, 3).Value

ws1.Range("f" & akhir1 + 1).Value = ws.Cells(baris, 4).Value

ws1.Range("g" & akhir1 + 1).Value = ws.Cells(baris, 5).Value

ws1.Range("h" & akhir1 + 1).Value = ws.Cells(baris, 6).Value

End If

End With

End Sub

Sub tampil()

Set ws = Sheets("Pemenang")

ws.Activate

ibow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(0, 0).Row

ListBox1.RowSource = "a4:e" & ibow + 1

End Sub

Sub listhadiah()

Dim ws As Worksheet

Set ws = Worksheets("Hadiah")

akhir = ws.Cells(Rows.Count, 1).End(xlUp).Row

Me.cmbHadiah.List = ws.Range("b3:b" & akhir).Value

End Sub

Sub hapusjikamenang()

If Me.CheckBox1.Value = True Then

Set ws = Worksheets("Peserta")

cari = Me.lblPemenang.Caption
With ws.Range("B:B")

Set hapusnya = .Find(cari, LookIn:=xlValues)

If Not hapusnya Is Nothing Then

baris = hapusnya.Row

ws.Cells(baris, 1).Delete shift:=xlUp

ws.Cells(baris, 2).Delete shift:=xlUp

ws.Cells(baris, 3).Delete shift:=xlUp

ws.Cells(baris, 4).Delete shift:=xlUp

ws.Cells(baris, 5).Delete shift:=xlUp

ws.Cells(baris, 6).Delete shift:=xlUp

End If

End With

Else

Exit Sub

End If

End Sub

FORM PESERTA

Private Sub cmdClear_Click()

Set ws = Worksheets("Peserta")

akhir = ws.Cells(Rows.Count, 1).End(xlUp).Row

If ws.Range("c4") = "" Then

Exit Sub

ElseIf MsgBox("Anda Yakin Untuk Menghapus Database Peserta Undian", vbYesNo + vbCritical,
"APLIKASI UNDIAN") = vbYes Then

ws.Range("a4:f" & akhir).ClearContents

Call tampil

ThisWorkbook.Save

Else

Exit Sub

End If

End Sub

Private Sub cmdImport_Click()

Call Module1.ImportDatafromotherworksheet

Call tampil

Call urut

Application.Visible = False
ThisWorkbook.Save

End Sub

Private Sub CommandButton1_Click()

Set ws = Worksheets("Peserta")

MsgBox "Tempat paste datanya di cell A" & Application.CountA(ws.Range("A:A")) + 1, vbInformation,


"APLIKASI UNDIAN"

End Sub

Sub tampil()

Set ws = Sheets("Peserta")

ws.Activate

ibow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(0, 0).Row

ListBox1.RowSource = "a4:f" & ibow + 1

End Sub

Private Sub UserForm_Activate()

Call tampil

Call urut

Me.ListBox1.Height = 236

End Sub

Sub urut()

On Error Resume Next

Set ws = Worksheets("Peserta")

akhir = ws.Cells(Rows.Count, 2).End(xlUp).Row

If ws.Range("b4") = "" Then

Exit Sub

Else

ws.Range("a4").Value = 1

ws.Range("a5").Value = 2

ws.Range("A4:A5").Select

selection.AutoFill Destination:=ws.Range("A4:A" & akhir), Type:=xlFillDefault

End If

End Sub

Private Sub UserForm_Initialize()

Call urut

End Sub
FORM PEMENANG

Private Sub txtCari_Change()

On Error GoTo err

If Me.txtCari.Text = "" Then

tampilsemua

Else

Dim myTange As Range

Dim criteria As Range

Set ws = Sheets("Pemenang")

Set ws1 = Sheets("Filter")

ibow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(0, 0).Row

Set myTange = ws.Range("a3:h" & ibow)

Set criteria = ws1.Range("j3:j4")

ws1.Range("j3") = "JENIS HADIAH"

ws1.Range("j4") = "*" & txtCari.Text & "*"

myTange.AdvancedFilter xlFilterCopy, criteria, ws1.Range("k3:r3"), False

ibow2 = ws1.Cells(Rows.Count, 11).End(xlUp).Offset(0, 0).Row

If ibow > 3 Then

ListBox1.RowSource = "Filter!k4:r" & ibow2 + 1

Else

ListBox1.RowSource = ""

End If

err: Exit Sub

End If

End Sub

Private Sub UserForm_Activate()

Me.ListBox1.Height = 228

End Sub

Private Sub UserForm_Initialize()

Set ws = Sheets("Pemenang")

ws.Activate

ibow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(0, 0).Row

ListBox1.RowSource = "a4:h" & ibow + 1


End Sub

Sub tampilsemua()

Set ws = Sheets("Pemenang")

ws.Activate

ibow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(0, 0).Row

ListBox1.RowSource = "a4:h" & ibow + 1

End Sub

FORM HADIAH

Dim lokasifoto As String

Private Sub cmdBatal_Click()

Me.cmdInput.Enabled = True

End Sub

Private Sub cmdDelete_Click()

Set ws = Worksheets("Hadiah")

If MsgBox("Anda Yakin Akan Menghapus " & Me.TextBox1.Value & "?", vbYesNo + vbQuestion,
"APLIKASI UNDIAN") = vbYes Then

cari = Me.ListBox1.Column(1)

With ws.Range("b:b")

Set datanya = .Find(cari, LookIn:=xlValues)

If Not datanya Is Nothing Then

baris = datanya.Row

ws.Cells(baris, 1).Delete shift:=xlUp

ws.Cells(baris, 2).Delete shift:=xlUp

ws.Cells(baris, 3).Delete shift:=xlUp

ws.Cells(baris, 4).Delete shift:=xlUp

End If

End With

Else

Exit Sub

End If

Me.TextBox1.Value = ""

Me.TextBox2.Value = ""

Me.Image1.Picture = Nothing

ThisWorkbook.Save
End Sub

Private Sub cmdEdit_Click()

Dim ws As Worksheet

Set ws = Worksheets("Hadiah")

cari = Me.TextBox1.Value

With ws.Range("b:b")

Set datanya = .Find(cari, LookIn:=xlValues)

If Not datanya Is Nothing Then

baris = datanya.Row

ws.Cells(baris, 2).Value = Me.TextBox1.Value

ws.Cells(baris, 3).Value = Me.TextBox2.Value

ws.Cells(baris, 4).Value = lokasifoto

End If

End With

Me.cmdInput.Enabled = True

Me.TextBox1.Value = ""

Me.TextBox2.Value = ""

Me.Image1.Picture = Nothing

ThisWorkbook.Save

End Sub

Private Sub cmdGambar_Click()

With Application.FileDialog(msoFileDialogFilePicker)

.AllowMultiSelect = False

.Filters.Add "File Foto", "*.jpg;*.jpeg"

If .Show = -1 Then

Image1.Picture = LoadPicture(.SelectedItems(1))

lokasifoto = .SelectedItems(1)

End If

End With

End Sub

Private Sub cmdInput_Click()

Set sh = Sheets("Hadiah")

akhir = sh.Cells(Rows.Count, 1).End(xlUp).Row

sh.Range("a" & akhir + 1).Value = "=Row()-2"

sh.Range("b" & akhir + 1).Value = Me.TextBox1


sh.Range("c" & akhir + 1).Value = Me.TextBox2

sh.Range("d" & akhir + 1).Value = lokasifoto

Call tampil

Call UTAMA.listhadiah

Me.TextBox1.Value = ""

Me.TextBox2.Value = ""

Me.Image1.Picture = Nothing

ThisWorkbook.Save

End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

Me.cmdInput.Enabled = False

On Error Resume Next

Set ws = Worksheets("Hadiah")

cari = Me.ListBox1.Column(1)

With ws.Range("b:b")

Set datanya = .Find(cari, LookIn:=xlValues)

If Not datanya Is Nothing Then

baris = datanya.Row

Me.TextBox1.Value = ws.Cells(baris, 2).Value

Me.TextBox2.Value = ws.Cells(baris, 3).Value

Image1.Picture = LoadPicture(ws.Cells(baris, 4).Value)

End If

End With

End Sub

Private Sub ToggleButton1_Click()

If Me.ToggleButton1.Value = True Then

HADIAH.Height = 316

Else

HADIAH.Height = 178

End If

End Sub

Private Sub UserForm_Activate()

Set ws = Sheets("Hadiah")

ws.Activate

ibow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(0, 0).Row

ListBox1.RowSource = "a3:d" & ibow + 1


End Sub

Sub tampil()

Set ws = Sheets("Hadiah")

ws.Activate

ibow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(0, 0).Row

ListBox1.RowSource = "a3:d" & ibow + 1

End Sub

Private Sub UserForm_Initialize()

HADIAH.Height = 178

Me.ListBox1.Height = 120

End Sub

You might also like