Angka ke terbilang vba excel

Private Sub CommandButton2_Click()
Dim i As Integer, a As Integer, MyNumber As Integer
For i = 7 To 50
Dim myarray(9) As String
        myarray(0) = " Zero "
        myarray(1) = "One"
        myarray(2) = "Two"
        myarray(3) = "Three"
        myarray(4) = "Four"
        myarray(5) = "Five"
        myarray(6) = "Six"
        myarray(7) = "Seven"
        myarray(8) = "Eight"
        myarray(9) = "Nine"
For a = 1 To Len(Range("B" & i).Value)
tmp = myarray(Mid(Range("B" & i), a, 1))
Range("C" & i) = Range("C" & i) & " " & tmp
Next a
        Next i
End Sub


UserFormya :Private Sub TextBox1_Change()
If TextBox1 <> "" Then
TextBox2 = Len(TextBox1)
Dim myarray(9) As String
        myarray(0) = " Zero "
        myarray(1) = "One"
        myarray(2) = "Two"
        myarray(3) = "Three"
        myarray(4) = "Four"
        myarray(5) = "Five"
        myarray(6) = "Six"
        myarray(7) = "Seven"
        myarray(8) = "Eight"
        myarray(9) = "Nine"
  Dim i As Integer, tmp As String
For i = 1 To Len(TextBox1)
tmp = tmp & " " & myarray(Mid(TextBox1, i, 1))
Next
  TextBox3 = tmp
          End If
End Sub

Singkat kata dengan VBA Excel

Private Sub TextBox1_Change()
Dim i As Integer, tmp As String, kangim() As String
kangim = Split(TextBox1)
For i = LBound(kangim) To UBound(kangim)
tmp = tmp & Mid(kangim(i), 1, 1)
Next
TextBox2 = tmp
End Sub

Kalao menggunakan UDF

Function Singkatan(ref As Range) As String
Dim i As Integer, tmp As String, kangim() As String
kangim = Split(ref)
For i = LBound(kangim) To UBound(kangim)
tmp = tmp & Mid(kangim(i), 1, 1)
Next
Singkatan = tmp
End Function

cara gunakannya
=Singkatan(B1)

Mengatasi ListView1 error lvwReport

dowonload active control 6
https://www.microsoft.com/en-us/download/confirmation.aspx?id=10019

Menggunakan Dua Office Sekaligus Dalam Satu Computer

Untuk menggunakan Dua Office dalam satu Computer, yang paling di butuhkan adalah kode perintah untuk menambahkan settingan di Registri computer kamu, berikut kodenya:
1. Kode untuk office 2003

reg add HKCU\Software\Microsoft\Office\11.0\Word\Options /v NoReReg /t REG_DWORD /d 1

2. Kode untuk office 2007

reg add HKCU\Software\Microsoft\Office\12.0\Word\Options /v NoReReg /t REG_DWORD /d 1

3. Kode untuk office 2010

reg add HKCU\Software\Microsoft\Office\14.0\Word\Options /v NoReReg /t REG_DWORD /d 1

4. Kode untuk office 2013
reg add HKCU\Software\Microsoft\Office\15.0\Word\Options /v NoReReg /t REG_DWORD /d 1

masukkan ke kotak Run

Cek semua TextBox ComboBox CheckBox kosong dengan VBA

Sub Cekdata()
Dim ctr As Control
For Each ctr In Me.Controls
If TypeOf ctr Is MSForms.TextBox Or TypeOf ctr Is MSForms.ComboBox Or TypeOf ctr Is MSForms.CheckBox Then
If ctr = vbNullString Or ctr = False Then
MsgBox ctr.Name & "Masih Kosong"
ctr.SetFocus
Exit Sub
End If
End If
Next ctr
End Sub

ComboBox untuk tanggal bulan bulan tahun sekarang

Private Sub UserForm_Activate()
 Dim i As Integer
        For i = 1 To 12
            ComboBox1.AddItem (Format(DateAdd("d", (i - 1), Now()), "[$-21]dd mmmm yyyy;@"))
            ComboBox2.AddItem (Format(DateAdd("d", (i - 1), Now()), "[$-21]dd;@"))
            ComboBox3.AddItem (Format(DateAdd("m", i, Now()), "[$-21]mmmm;@"))
            ComboBox4.AddItem (Format(DateAdd("m", -1 + (i - 1) * 12, Now()), "[$-21]yyyy;@"))
        Next i
End Sub

Memasukan Data Textbox ke ListView dengan Tombol pada UserForm

Private Sub CmdTambahListviuw_Click()
Dim lvwItem As ListItem
With ListView1
Set lvwItem = .ListItems.Add(, , TextBox1.Value)
lvwItem.SubItems(1) = TextBox2.Value
lvwItem.SubItems(2) = TextBox3.Value
End With
End Sub

Dan untuk nampilkan semua data dalam ListView

Private Sub UserForm_Activate()
Dim wksSource As Worksheet
Dim rngData As Range
Dim rngCell As Range
Dim LstItem As ListItem
Dim RowCount As Long
Dim ColCount As Long
Dim i As Long
Dim j As Long

Set wksSource = Worksheets("Sheet1")
Set rngData = wksSource.Range("A1").CurrentRegion

For Each rngCell In rngData.Rows(1).Cells
Me.ListView1.ColumnHeaders.Add Text:=rngCell.Value, Width:=90
Next rngCell

RowCount = rngData.Rows.Count
ColCount = rngData.Columns.Count

For i = 2 To RowCount
Set LstItem = Me.ListView1.ListItems.Add(Text:=rngData(i, 1).Value)
For j = 2 To ColCount
LstItem.ListSubItems.Add Text:=rngData(i, j).Value
Next j
Next i
End Sub

Memisahkan Duplikat dan data Unik dengan VBA Excel

Private Sub CommandButton1_Click()
i = 1
J = 0
k = 0
With ThisWorkbook.Sheets("Sheet2")
.[C:C,D:D,E:E].ClearContents
Do
If Application.WorksheetFunction.CountIf(.[C:C], .Cells(i, 1).Value) Then
J = J + 1
.Cells(J, 5).Value = .Cells(i, 1).Value
Else
k = k + 1
.Cells(k, 3).Value = .Cells(i, 1).Value
.Cells(k, 4).Value = Application.WorksheetFunction.CountIf(.[A:A], .Cells(k, 3).Value)
End If
i = i + 1
If .Cells(i, 1).Value = Empty Then Exit Do
Loop
End With
End Sub

Buat No urut diantara dua kolom dengna VBA ( UDF )

Taroh kode dibawah ini pada Modul

Public Function DesiredFunction(first As Integer, last As Integer)
Dim i As Integer

If first > last Then
DesiredFunction = "Error!"
End If

For i = first To last
If i = first Then
DesiredFunction = i
Else
DesiredFunction = DesiredFunction & "," & i
End If
Next i
End Function

Terbilang dengan Rupiah ( UDF VBA Excel )

Public Function Terbilang(x As Currency) Dim triliun As Currency Dim milyar As Currency Dim juta As Currency Dim ribu As Currency Dim satu As Currency Dim sen As Currency Dim baca As String If x > 1000000000000# Then Terbilang = "< di atas satu triliun rupiah >" Exit Function End If 'Jika x adalah 0, maka dibaca sebagai 0 If x = 0 Then baca = angka(0, 1) Else 'Pisah masing-masing bagian untuk triliun, milyar, juta, ribu, rupiah, dan sen triliun = Int(x * 0.001 ^ 4) milyar = Int((x - triliun * 1000 ^ 4) * 0.001 ^ 3) juta = Int((x - triliun * 1000 ^ 4 - milyar * 1000 ^ 3) / 1000 ^ 2) ribu = Int((x - triliun * 1000 ^ 4 - milyar * 1000 ^ 3 - juta * 1000 ^ 2) / 1000) satu = Int(x - triliun * 1000 ^ 4 - milyar * 1000 ^ 3 - juta * 1000 ^ 2 - ribu * 1000) sen = Int((x - Int(x)) * 100) 'Baca bagian triliun dan ditambah akhiran triliun If triliun > 0 Then baca = ratus(triliun, 5) + "triliun " End If 'Baca bagian milyar dan ditambah akhiran milyar If milyar > 0 Then baca = ratus(milyar, 4) + "milyar " End If 'Baca bagian juta dan ditambah akhiran juta If juta > 0 Then baca = baca + ratus(juta, 3) + "juta " End If 'Baca bagian ribu dan ditambah akhiran ribu If ribu > 0 Then baca = baca + ratus(ribu, 2) + "ribu " End If 'Baca bagian rupiah dan ditambah akhiran rupiah If satu > 0 Then baca = baca + ratus(satu, 1) + "rupiah " Else baca = baca + "rupiah" End If 'Baca bagian sen dan ditambah akhiran sen If sen > 0 Then baca = baca + ratus(sen, 0) + "sen" End If End If Terbilang = UCase(Left(baca, 1)) & LCase(Mid(baca, 2)) End Function Function ratus(x As Currency, Posisi As Integer) As String Dim a100 As Integer, a10 As Integer, a1 As Integer Dim baca As String a100 = Int(x * 0.01) a10 = Int((x - a100 * 100) * 0.1) a1 = Int(x - a100 * 100 - a10 * 10) 'Baca Bagian Ratus If a100 = 1 Then baca = "Seratus " Else If a100 > 0 Then baca = angka(a100, Posisi) + "ratus " End If End If 'Baca Bagian Puluh dan Satuan If a10 = 1 Then baca = baca + angka(a10 * 10 + a1, Posisi) Else If a10 > 0 Then baca = baca + angka(a10, Posisi) + "puluh " End If If a1 > 0 Then baca = baca + angka(a1, Posisi) End If End If ratus = baca End Function Function angka(x As Integer, Posisi As Integer) Select Case x Case 0: angka = "Nol" Case 1: If Posisi <= 1 Or Posisi > 2 Then angka = "Satu " Else angka = "Se" End If Case 2: angka = "Dua " Case 3: angka = "Tiga " Case 4: angka = "Empat " Case 5: angka = "Lima " Case 6: angka = "Enam " Case 7: angka = "Tujuh " Case 8: angka = "Delapan " Case 9: angka = "Sembilan " Case 10: angka = "Sepuluh " Case 11: angka = "Sebelas " Case 12: angka = "Duabelas " Case 13: angka = "Tigabelas " Case 14: angka = "Empatbelas " Case 15: angka = "Limabelas " Case 16: angka = "Enambelas " Case 17: angka = "Tujuhbelas " Case 18: angka = "Delapanbelas " Case 19: angka = "Sembilanbelas " End Select End Function

Menghapus Check Box pada vba excel di Form

Sub HapusCheckBox()
Dim Ctrl As Control
         For Each Ctrl In Me.Controls
       If TypeOf Ctrl Is MSForms.CheckBox Then: Ctrl.Value = False
      Next Ctrl
End Sub

BUNGKUS DAN ISI

Hidup akan sangat melelahkan, sia-sia dan menjemukan bila pikiran hanya digunakan untuk mencari dan mengurus BUNGKUS-nya saja serta mengabaikan dan mengacuhkan ISI-nya.
Apa itu “BUNGKUS”-nya,
Dan apa itu “ISI”-nya?.

“Rumah yang indah” hanya bungkusnya.
“Keluarga bahagia” itu isinya.

“Pesta pernikahan” hanya bungkusnya.
“Sakinah, mawadah, warahmah” itu isinya.

“Ranjang mewah” hanya bungkusnya.
“Tidur nyenyak” itu isinya.

“Kekayaan” itu hanya bungkusnya.
“Hati yang bahagia” itu isinya.

“Makan enak” hanya bungkusnya.
“Gizi, energi, dan sehat” itu isinya.

“Kecantikan dan Ketampanan” hanya bungkusnya.
“Kepribadian dan hati” itu isinya.

“Bicara” itu hanya bungkusnya.
“Amal nyata” itu isinya.

“Buku” hanya bungkusnya.
“Pengetahuan” itu isinya.

“Jabatan” hanya bungkusnya.
“Pengabdian dan pelayanan” itu isinya.

“Kharisma” hanya bungkusnya.
“Ahlaqul karimah” itu isinya.

“Hidup di dunia” itu bungkusnya.
“Hidup sesudah mati” itu isinya.

Utamakanlah ISI-nya.
Namun rawatlah BUNGKUS-nya.

Jangan memandang rendah dan hina setiap BUNGKUS yang kita terima, karena berkah tak selalu datang dari BUNGKUS kain sutera melainkan juga datang dari BUNGKUS koran bekas.

Janganlah setengah mati mengejar apa yang tak bisa kita bawa mati

INFO YANG JARANG DIKETAHUI ORANG...

INFO YANG JARANG DIKETAHUI ORANG...

1. Nomor Darurat utk telepon genggam adalah 112. Jika anda sedang di daerah yg tdk menerima sinyal HP & perlu memanggil pertolongan, silahkan tekan 112 dan HP akan mencari otomatis network apapun yg ada utk menyambung kan nomor darurat bagi anda. Dan yg menarik, nomor 112 dpt ditekan biarpun keypad dlm kondisi di lock.

2. Kunci mobil anda ketinggalan di dlm mobil? Anda memakai kunci remote? Kalau kunci anda ketinggalan dlm mobil & remote cadangan nya ada di rumah, anda segera telpon orang rmh dgn HP, lalu dekatkan HP anda kurang lebih 30cm dari mobil & minta org rumah utk menekan tombol pembuka pd remote cadangan yg ada dirumah. Pd waktu menekan tombol pembuka remote, minta org rmh mendekatkan remotenya ke telepon cellular yg dipakainya.

3. Tips untuk menge-Check keabsahan mobil/motor anda. Ketik: contoh JATIM L8630NS (no plat mobilanda) Kirim ke 1717, nanti akan dpt balasan dari kepolisian mengenai data2 kendaraan anda, tips ini jg berguna untuk mengetahui data2 mobil bekas yg hendak anda akan beli.

4. Jika anda sedang terancam jiwanya krn dirampok/ditodong seseorang untuk mengeluarkan uang dari ATM, maka anda bisa minta pertolongan diam2 dgn memberikan nomor PIN scara terbalik, misal no asli PIN anda 1254 input 4521 di ATM maka mesin akan mengeluarkan uang anda juga tanda bahaya ke kantor polisi tanpa diketahui penodong tsb. Fasilitas ini tersedia di seluruh ATM tapi hanya sedikit org yg tahu (tolong disebarkan).

5.Lupa dng nomer sendiri ? Nggak usah missedcall org biar bisa tau no Sendiri?, nih ada cara cek no sendiri :
Axis : *2#
Xl : *123*7*2*1*1#
Smartfren : *995#
Simpati : *808#
Tri : *998#
Indosat : *123*30#

(SEMOGA BERMANFAAT).

"Cukup Letakkan Gelasnya"

Seorang dosen mulai kuliah dengan memegang gelas berisi air, “Berapa berat gelas ini”, tanyanya pada mahasiswa sambil mengangkat gelas tersebut agak tinggi hingga seluruh mahasiswa bisa melihatnya.
“50 gr..100 gr..150 gr..entahlah” jawab seorang mahasiswa
“Well, kita takkan tahu jika tak menimbang” jawab sang dosen

“Pertanyaannya adalah, apa yang terjadi kalau saya angkat gelas ini selama 3 menit?” lanjutnya
“Takkan terjadi apa-apa” kali ini jawaban seorang mahasiswa terdengar sangat meyakinkan

Dosen melanjutkan “Kalau saya angkatnya sejam”
“Wah..tangan Anda akan keram Prof” jawab mahasisWA

“Bagaimana kalau seharian?” tanya sang dosen belum puas
“Entahlah. Mungkin tangan Anda mati rasa, otot terluka mungkin lumpuh. Dan harus dibawa kerumah sakit”. Seisi ruangan pun tertawa

“Betul sekali. Lantas apakah berat gelas ini akan berubah?”
“Tidak Prof”

“Lalu apa yang harus saya lakukan supaya hal-hal buruk di atas tak perlu terjadi?". 

Sang dosen terus bertanya
“Anda tak boleh lupa untuk meletakkan gelasnya”

“Persis ! Jangan angkat gelasnya terlalu lama”

HIKMAH : 
Masalah hidup layaknya gelas tadi, semakin lama kita bawa, semakin lama terbebani, semakin menderita pula.

Sebenarnya, bobot masalah itu takkan berubah sedikitpun. Hanya kita begitu lama memikirkannya. 
Benar, bahwa setiap masalah memang harus difikirkan untuk dicari solusinya, tapi yang terpenting adalah bagaimana kita mempercayakan semuanya HANYA kepada Allah. Bahwa di tanganNyalah segala kuasa. Dia yang mengatur alam semesta, menjaga keseimbangannya, sangat mustahil jika Dia lupa memberi jalan keluar.

 (Qs. Al Fath : 4)

Ketenangan hati adalah bukti kuatnya iman. Sebaliknya kita harus hati-hati saat dilanda terlbanyak kegelisahan, seolah masalah kita sangat besar, hingga merasa sebagai manusia paling menderita di muka bumi. Karena bisa jadi, saat itu iman kita sedang berada di titik nadhir hingga syaithan leluasa menggoda.

Hiduplah dengan semangat pemburu syurga, niscaya takkan ada masalah yang terlalu berat terasa...

SEMANGAT PAGI...
Salam SUKSES & BERKAH...

Membuat tombol PDF dengan vb di excel

Insert CommandButton dan masukkan kode vb di bawah ini


Private Sub CommandButton1_Click()
PageSetup.PaperSize = xlPaperA4
NamaFile = Range("E94").Value
ActiveSheet.Range("A1:K160").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        ThisWorkbook.Path & "\PDF\" & NamaFile, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        False
    DoEvents
    MsgBox "Sudah di simpan di PDF"
End Sub

Membuat Gambar JPG di EXcel dengan vb

Cara buat gambar dari Range tertentu dengan macro sebagai berikut :
Insert button dan tulis kode berikut

Private Sub CommandButton1_Click()
                  'Set Rentang Anda ingin ekspor ke file
Dim rgExp As Range: Set rgExp = Worksheets("KARTU").Range("A89:K115")
                 'Salin kisaran sebagai gambar ke Clipboard
rgExp.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
               '' 'Buat grafik kosong dengan ukuran yang tepat dari berbagai disalin
With ActiveSheet.ChartObjects.Add(Left:=rgExp.Left, Top:=rgExp.Top, _
Width:=rgExp.Width, Height:=rgExp.Height)
.Name = "ChartVolumeMetricsDevEXPORT"
.Activate
End With
                  '' 'Paste ke daerah grafik, ekspor ke file, menghapus grafik.
ActiveChart.Paste
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Chart.Export ActiveWorkbook.Path & "\GAMBAR\KARTU.jpg"
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Delete
End Sub

Mermbuat Print gak fungsi atau Error dengan Vb

Nah untuk membuat Print gak berfungsi bisa coba memasukkan scrib ini pada
Thisworkbook

Private Sub Workbook_BeforePrint(Cancel As Boolean) Cancel = True MsgBox "Di larang cetak File ini ", vbOKOnly, “Error” End Sub

Membuat Tombol close (X) worksheet gak berfungsi di Excel dengan VB

Nah untuk membuat Tombol close (X) worksheet gak berfungsi bisa coba memasukkan scrib ini pada 

Thisworkbook
Public myFlg As Boolean
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Letakkan ini pada "ThisWorkbook"
If myFlg = True Then Exit Sub
Application.DisplayAlerts = False
Cancel = True
End Sub
Sub myClose()
myFlg = True
Application.DisplayAlerts = False
ActiveWindow.Close False
End Sub

CARA BUAT CHEKBOX DI FORM EXCEL DAN TOMBOL SIMPANNYA

Private Sub CommandButton1_Click()
Dim str As String
Dim Hom As Long
Hom = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
For Each ctrl In Frame1.Controls
If TypeOf ctrl Is MSForms.CheckBox Then
If ctrl.Value = True Then
Label1.Caption = Label1.Caption & ", " & ctrl.Caption
End If
End If
Next ctrl
Sheet1.Cells(Hom + 1, "A").Value = Right(Label1.Caption, Len(Label1.Caption) - 2)
Label1.Caption = ""
End Sub

Private Sub CommandButton2_Click()
Dim str As String
Dim Hom As Long
Hom = Sheet1.Range("B" & Rows.Count).End(xlUp).Row

If CheckBox1.Value = True Then
str = str & CheckBox1.Caption & ", "
End If
If CheckBox2.Value = True Then
str = str & CheckBox2.Caption & ", "
End If
If CheckBox3.Value = True Then
str = str & CheckBox3.Caption & ", "
End If
If CheckBox4.Value = True Then
str = str & CheckBox4.Caption & ", "
End If
If CheckBox5.Value = True Then
str = str & CheckBox5.Caption & ", "
End If
If CheckBox6.Value = True Then
str = str & CheckBox6.Caption & ", "
End If
If CheckBox7.Value = True Then
str = str & CheckBox7.Caption & ", "
End If
If CheckBox8.Value = True Then
str = str & CheckBox8.Caption & ", "
End If
If CheckBox9.Value = True Then
str = str & CheckBox9.Caption & ", "
End If
If CheckBox10.Value = True Then
str = str & CheckBox10.Caption & ", "
End If

str = Left(str, Len(str) - 2)
Sheet1.Cells(Hom + 1, "B").Value = str

End Sub

MEMBUAT APLIKASI ARISAN DENGAN VB EXCEL

Cara penggunaanya iuran diisi terlebih dahulu dan setelah itu no di isi
Setelah No diisi dan di enter maka angsuran masuk ke kolom D dan bila sudah ada isinya di simpan di colom E
kode vb maronya adalah
Private Sub Worksheet_Change(ByVal Target As Range)
Dim CellTujuan As Object
Dim Kode As Variant
Dim KolomKosong As Object
Dim JmlhData As Double
Kode = Target.Value
On Error GoTo eror:
    If Not Intersect(Target, Range("N3")) Is Nothing Then
        If Target > 0 Then
            Set CellTujuan = Sheet1.Range("B:B").Find(What:=Kode, LookIn:=xlValues, LookAt:=xlWhole)
        Set KolomKosong = CellTujuan.Offset(0, 2)
        JmlhData = WorksheetFunction.CountA(Range(KolomKosong, KolomKosong.End(xlToRight)))
            If KolomKosong <> "" Then
            Set KolomKosong = CellTujuan.Offset(0, 2 + JmlhData)
            End If
        KolomKosong.Value = Range("K8").Value
        End If
        End If
Exit Sub
eror:
MsgBox "Data Tidak Ditemukan"
End Sub
DOWLOAD contoh filenya