Conversi Angka ke Abajat - Excel VBA

Function ColumnLetter(ColumnNumber As Long) As String

Dim n As Long

Dim c As Byte

Dim s As String

n = ColumnNumber

Do

c = ((n - 1) Mod 26)

s = Chr(c + 65) & s

n = (n - c) \ 26

Loop While n > 0

 ColumnLetter = s

End Function

cara menggunakan 

= ColumnLetter (a1)

silahkan mencoba

Function getColIndex(sColRef As String) As Long

  Dim sum As Long, iRefLen As Long

  sum = 0: iRefLen = Len(sColRef)

  For i = iRefLen To 1 Step -1

    sum = sum + Base26(Mid(sColRef, i)) * 26 ^ (iRefLen - i)

  Next

  getColIndex = sum

End Function

Private Function Base26(sLetter As String) As Long

  Base26 = Asc(UCase(sLetter)) - 64 'fixed

End Function

cara menggunakan 

=getColIndex(a1)


Demikian contoh fungsi vba silahkan dikembangkan
 semoga bermanfaat !!!

Disable Copy Paste Excel File to Another Computer - Excel VBA

         

Kadang kita membuat file excel namun takut disalah gunakan oleh orang yang tidak bertanggung jawab dengan mengkopy isi sheet bahkan mengkopy file excel kita

         Ada beberapa tip untuk mengamankan file anda diantaranya adalah Mendisable file excel dicopy ke Computer lain

File bias dicopy ke computer lain namun file akan ditolak dan langsung terhapus bila seri no tidak sesuai dengan kode number serial yang dipasang di file tersebut sehingga file excel anda akan tetap aman

         Untuk mengetahui no Serial Hardis dari sebuah computer pastekan kode berikut pada sebuah modul

Sub Cek_noHardis ()

Sheets("Sheet1").Range("b1").Value = CreateObject("Scripting.FileSystemObject").GetDrive("C:\").SerialNumber

End Sub

Dan Kemudian Kode yang muncul akan kita pasang pada file excel kita  sesuai no seri hardis untuk computer yang bisa mengakses file tersebut

‘Pastekan kode pada Workbook sesuaikan no seri nya

Private Sub Workbook_Open()

Dim oFSO As Object

 Dim drive As Object

 Set oFSO = CreateObject("Scripting.FileSystemObject")

Set drive = oFSO.GetDrive("C:\")

If drive.SerialNumber <> 408299609 Then

Application.Run "Killy"

Set oFSO = Nothing

Set drive = Nothing

End If

End Sub

 ‘Pastekan pada modul

Sub Killy()

MsgBox "Illegal Copy ", vbExclamation + vbMsgBoxRight

Application.DisplayAlerts = False

ThisWorkbook.ChangeFileAccess xlReadOnly

Kill ThisWorkbook.FullName

ThisWorkbook.Close False

 Application.DisplayAlerts = False

End Sub

Untuk mendisabel copy paste dilembar excel pastekan juga kode berikut pada wookbook

Private Sub Workbook_Activate()

Application.CutCopyMode = False

Application.OnKey "^c", ""

Application.CellDragAndDrop = False

End Sub

Private Sub Workbook_Deactivate()

Application.CellDragAndDrop = True

Application.OnKey "^c"

Application.CutCopyMode = False

End Sub

Private Sub Workbook_WindowActivate(ByVal Wn As Window)

Application.CutCopyMode = False

Application.OnKey "^c", ""

Application.CellDragAndDrop = False

End Sub

Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)

Application.CellDragAndDrop = True

Application.OnKey "^c"

Application.CutCopyMode = False

End Sub

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

Cancel = True

MsgBox "Right click menu deactivated." & vbCrLf & _

"Cannot copy or ''drag & drop''.", 16, "For this workbook:"

End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

Application.CutCopyMode = False

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

Application.OnKey "^c", ""

Application.CellDragAndDrop = False

Application.CutCopyMode = False

End Sub

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)

Application.CutCopyMode = False

End Sub

Selamat Mencoba

Semoga bermanfaat

Copying multiple columns into one column - vba excel

 Sub MultyCol_to_OneColl ()

Dim arr() As Variant

Dim rng As Range

Dim x As Long

Application.ScreenUpdating = False

arr = Sheets("Sheet1").Range("A2:C100").Value

 For x = LBound(arr, 2) To UBound(arr, 2)

 With Sheets("Sheet1")

Set rng = .Cells(.Rows.Count, 4).End(xlUp).Offset(1)

 rng.Resize(UBound(arr, 1)).Value = Application.Index(arr, , x)

 Set rng = Nothing

End With

Next x

Erase arr

Application.ScreenUpdating = True

 End Sub

Sub MultyCol_to_One_Transpose()

Dim i As Integer

Dim rng As Range

Set rng = Sheet1.Range("C2").CurrentRegion

 For i = 1 To rng.Count

Sheet1.Cells(1 + i, 4) = rng(i)

Next i

End Sub

Sub MultyCol_to_OneColl_transpose()

Dim arr() As Variant

Dim rng As Range

Dim x As Long

Application.ScreenUpdating = False

arr = Sheets("Sheet1").Range("A2:C100").Value

 For x = LBound(arr, 2) To UBound(arr, 2)

 With Sheets("Sheet1")

Set rng = .Cells(.Rows.Count, 4).End(xlUp).Offset(1)

 rng.Resize(UBound(arr, 1)).Value = Application.Index(arr, , x)

 Set rng = Nothing

End With

Next x

Erase arr

Application.ScreenUpdating = True

With Worksheets("sheet1")

.Range(Range("d2"), Range("d2").End(xlDown)).Copy

.Range("e2").PasteSpecial Transpose:=True

.Range(Range("d2"), Range("d2").End(xlDown)).Value = ""

End With

 End Sub

Satgas COVID 19 - ENTRI DATA PENDATANG

Keterangan Aplikasi            

            Mengghadapi Pandemi COVID 19      

            Mengharuskan kita selalu waspada dan     

            mengantisipasi diantaranya mendata Pendatang          

            dari luar daerah dan mengambil tindakan yang 

            dianggap perlu dan termasuk kategori       

            Orang Dalam Pengawasan ( ODP)    

            Aplikasi ini akan membantu menghitung lama hari       

            kedatangannya    

            dibawah 14 hari  kedatangannya masih dalam status ODP     

            Bila sudah lebih 14 hari mungkin sudah bisa         

            masuk kategori aman dengan berbagai     

            pertimbangan lainnya .

            Semoga bermanfaat  !!!

Kritik dan saran positip sangat kami harapkan!

Aplikasi ini tanpa protect vba

Silahkan dikembangkan !

Semoga bermanfaat

Unduh aplikasi pada link berikut:

LINK GRATIS Ebook Pdf

1. Mudul Mengenal UDF

Disini

2. Kosa Kata Dasar VBA

Disini

LINK GRATIS APLIKASI

1. Aplikasi Wali Kelas

Disini

2. Aplikasi Foto Kalender

Disini

LINK GRATIS 
KUMPULAN RUMUS EXCEL

DISINI

Semoga Bermanfaat!!

Untuk Aplikasi aplikasi gratisnya

lainnya cek diblog ini pada Label "Aplikasi"

Terima kasih atas kunjungannya

diblog ini !!!

Dapatkan Segera Paket Belajar 
full Visual Basic for Aplication 
Membuat Anda 
Selangkah Lebih Maju

Cek Paket Disini

Satgas Covid 19

INPUT DATA PENERIMA BANTUAN - APLIKASI EXCEL GRATIS

APLIKASI VERSI EXCEL VBA

APLIKASI INPUT DATA PENERIMA BANTUAN

Aplikasi ini adalah aplikasi sederhana 

silahkan dimodif sesuai kepentingan

dilingkungan masing - masing

semoga bermanfaat !!!

unduh gratis disini >>> Aplikasi Input Data

MEMBUAT USERFORM INPUT SEDERHANA -EXCEL VBA

Pastekan pada CommandButton1

Private Sub CommandButton1_Click()

Dim irow As Long

irow = Worksheets("sheet1").Cells(Rows.Count, 2).End(xlUp).Offset(1, 1).Row

Worksheets("sheet1").Cells(irow, 2).Value = TextBox1.Value

Worksheets("sheet1").Cells(irow, 3).Value = TextBox2.Value

Sheets("sheet1").Range("a1") = Application.CountA(Range("b5:b20"))

No = 0

For NOMOR = 1 To Range("a1")

No = No + 1

Cells(No + 4, 1).Value = No

Next NOMOR

End Sub

Pastekan pada Userform

Private Sub UserForm_Initialize()

 ListBox1.ColumnCount = 3

 ListBox1.ColumnWidths = 50 & ";" & 100 & ";" & 150

 ListBox1.RowSource = "data"

End Sub

COUNTIF IF DAN MAX - RUMUS EXCEL

COUNTIF

                 Fungsi COUNTIF Dalam Rumus Excel dapat digunakan untuk menghitung banyaknya sel yang memenuhi syarat, kriteria atau kondisi tertentu. Misalnya menghitung banyaknya sel kosong, menghitung sel berisi bilangan tertentu, sel berisi tanggal tertentu, maupun sel berisi text atau karakter tertentu.

=COUNTIF($B$2:$B$9;C2)
=COUNTIF($B$2:$B$9;'"p")

=COUNTIF(C2:C8;">"&E4)

=COUNTIF(C2:C8;80)

=COUNTIF(B2:B8;"Apel")

=Countif($B$2:$B$9;Max($B$2:$B$9))

=IF(COUNTIF(B2:B3;B3)=2;0;IF(COUNTIF(B3:B3;B3)=1;B3;0))