KUMPULAN SCRIPT VISUAL BASIC Visual Basic (VB) MICROSOFT EXCEL

Kumpulan Script Visual Basic ( VB ) Microsoft Excel

Kita perlu mempelajari Visual Basic ( VB ) yang ada di Microsoft Excel. Karena Script ini jika kita buat akan memudahkan orang bekerja jika aplikasi sudah jadi. Bagi orang yang ingin belajar bahasa pemograman Visual Basic memang dari Microsoft Excel sebagai dasar belajarnya karena mudah dipahami.  Selamat mempelajari materi yang saya tulis ini semoga bermanfaat.

Coding VBA (Macro) Excel Menampikan Dokumen Di Layar Monitor

Sub PrintPreview()

Worksheets("Sheet1").PrintPreview

End Sub

Sheet1 disesuaikan nama sheetnya. Misal nama sheet diganti informatika ya di script disesuaikan

Coding VBA (Macro) Excel Menyimpan File Yang Baru Dibuat

Sub Save()

ActiveWorkbook.Save

End Sub

Coding VBA (Macro) Excel Keluar File

Sub Quit()

Application.Quit

End Sub

Coding VBA (Macro) Excel Menyisipkan Gambar Di Dokumen

Sub insertpic()

Dim FilestoOpen

FilestoOpen = Application.GetOpenFilename("Picture File (*.jpg), *.jpg,(*.png), *.png", , "Insert Picture", , False)

ActiveSheet.Pictures.Insert (OpenFilestoOpen)

End Sub

Coding VBA (Macro) Excel Backup File

Sub FileBackUp()

ThisWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & _

"" & Format(Date, "mm-dd-yy") & " " & _

ThisWorkbook.name

End Sub

Coding VBA (Macro) Menutup Semua File Kecuali yang Aktif

Sub CloseAllWorkbooks()

Dim wbs As Workbook

For Each wbs In Workbooks

wbs.Close SaveChanges:=True

Next wbs

End Sub

Coding VBA (Macro) Menyembunyikan Worksheet

Sub HideWorksheet()

Dim ws As Worksheet

For Each ws In ThisWorkbook.Worksheets

If ws.Name <> ThisWorkbook.ActiveSheet.Name Then

ws.Visible = xlSheetHidden

End If

Next ws

End Sub

Coding VBA (Macro) Menampilkan Semua Worksheet yang Tersembunyi

Sub UnhideAllWorksheet()

im ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets

ws.Visible = xlSheetVisible

Next ws

End Sub

Coding VBA (Macro) Menghapus Semua Worksheet

Sub DeleteWorksheets()

Dim ws As Worksheet

For Each ws In ThisWorkbook.Worksheets

If ws.name <> ThisWorkbook.ActiveSheet.name Then

Application.DisplayAlerts = False

ws.Delete

Application.DisplayAlerts = True

End If

Next ws

End Sub

Coding VBA (Macro) Mengcopy Sheet Aktif kedalam Workbook Baru

Sub CopyWorksheetToNewWorkbook()

ThisWorkbook.ActiveSheet.Copy _

Before:=Workbooks.Add.Worksheets(1)

End Sub

Coding VBA (Macro) Proteksi Semua Worksheet

Sub ProtectAllWorskeets()

Dim ws As Worksheet

Dim ps As String

ps = InputBox("Enter a Password.", vbOKCancel)

For Each ws In ActiveWorkbook.Worksheets

ws.Protect Password:=ps

Next ws

End Sub

Coding VBA (Macro) Mengkonversi Rumus kedalam Format Value

Sub ConvertToValues()

Dim MyRange As Range

Dim MyCell As Range

Select Case MsgBox("You Can't Undo This Action. " & "Save Workbook First?", vbYesNoCancel, "Alert")

Case Is = vbYes

ThisWorkbook.Save

Case Is = vbCancel

Exit Sub

End Select

Set MyRange = Selection

For Each MyCell In MyRange

If MyCell.HasFormula Then

MyCell.Formula = MyCell.Value

End If

Next MyCell

End Sub

Coding VBA (Macro) Menghapus Spasi

Sub RemoveSpaces()

Dim myRange As Range

Dim myCell As Range

Select Case MsgBox("You Can't Undo This Action. " & "Save Workbook First?", _

vbYesNoCancel, "Alert")

Case Is = vbYesThisWorkbook.Save

Case Is = vbCancel

Exit Sub

End Select

Set myRange = Selection

For Each myCell In myRange

If Not IsEmpty(myCell) Then

myCell = Trim(myCell)

End If

Next myCell

End Sub

Coding VBA (Macro) Memberi Tanda Data yang Dianggap Ganda (Duplikat)

Sub HighlightDuplicateValues()

Dim myRange As Range

Dim myCell As Range

Set myRange = Selection

For Each myCell In myRange

If WorksheetFunction.CountIf(myRange, myCell.Value) > 1 Then

myCell.Interior.ColorIndex = 36

End If

Next myCell

End Sub

Coding VBA (Macro) Mengimpor File Excel Ke PDF

Sub SaveAsPDF()

Selection.ExportAsFixedFormat Type:=xlTypePDF, OpenAfterPublish:=True

End Sub

Coding VBA (Macro) Menghapus Karakter dari String

Public Function removeFirstC(rng As String, cnt As Long)

removeFirstC = Right(rng, Len(rng) - cnt)

End Function

Coding VBA (Macro) Menyimpan Range kedalam Bentuk Gambar

Sub PasteAsPicture()

Application.CutCopyMode = False

Selection.Copy

ActiveSheet.Pictures.Paste.Select

End Sub

Coding VBA (Macro) Cara Memberikan Tanda pada 10 Besar

Sub TopTen()

Selection.FormatConditions.AddTop10

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority

With Selection.FormatConditions(1)

.TopBottom = xlTop10Top

.Rank = 10

.Percent = False

End With

With Selection.FormatConditions(1).Font

.Color = -16752384

.TintAndShade = 0

End With

With Selection.FormatConditions(1).Interior

.PatternColorIndex = xlAutomatic

.Color = 13561798

.TintAndShade = 0

End With

Selection.FormatConditions(1).StopIfTrue = False

End Sub

Coding VBA (Macro) Menambahkan Nomor Seri (Serial Number)

Sub AddSerialNumbers()

Dim i As Integer

On Error GoTo Last

i = InputBox("Enter Value", "Enter Serial Numbers")

For i = 1 To i

ActiveCell.Value = i

ActiveCell.Offset(1, 0).Activate

Next i

Last:

Exit Sub

End Sub

Coding VBA (Macro) Protek dan Unprotect Worksheet

Sub ProtectWS()

ActiveSheet.Protect "mypassword", True, True

End Sub

Sub UnprotectWS()

ActiveSheet.Unprotect "mypassword"

End Sub

Coding VBA (Macro) Merubah Tulisan Menjadi Huruf Besar

Sub ConvertUpperCase()

Dim rng As Range

For Each rng In Selection

rng = UCase(rng)

Next rng

End Sub

Coding VBA (Macro)Merubah Tulisan Menjadi Hurup Kecil

Sub ConvertLowerCase()

Dim rng As Range

For Each rng In Selection

rng = LCase(rng)

Next rng

End Sub

Coding VBA (Macro) Menyesuaikan Kolom dan Baris Sesuai Ukuran atau Lebar Text

Sub AutoFitColumns()

Cells.Select

Cells.EntireColumn.AutoFit

End Sub

Sub AutoFitRows()

Cells.Select

Cells.EntireRow.AutoFit

End Sub

Coding VBA (Macro) Mengurutkan Nama Worksheet

Sub SortWorksheets()

Dim i As Integer

Dim j As Integer

Dim iAnswer As VbMsgBoxResult

iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _

& "Clicking No will sort in Descending Order", _

vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")

For i = 1 To Sheets.Count

For j = 1 To Sheets.Count - 1

If iAnswer = vbYes Then

If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then

Sheets(j).Move After:=Sheets(j + 1)

End If

ElseIf iAnswer = vbNo Then

If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then

Sheets(j).Move After:=Sheets(j + 1)

End If

End If

Next j

Next i

End Sub

Coding VBA (Macro) Membuat text to Speak

Sub Speak()

Selection.Speak

End Sub

Coding VBA (Macro) Menutup Pesan Otomatis

Sub auto_close()

MsgBox "Bye Bye! Don't forget to check other cool stuff on excelchamps.com"

End Sub

Coding VBA (Macro)Konversi Format Tanggal ke Text

Sub date2day()

Dim tempCell As Range

Selection.Value = Selection.Value

For Each tempCell In Selection

If IsDate(tempCell) = True Then

With tempCell

.Value = Day(tempCell)

.NumberFormat = "0"

End With

End If

Next tempCell

End Sub

Coding VBA (Macro) Konversi Tanggal Menjadi Tahun

Sub date2year()

Dim tempCell As Range

Selection.Value = Selection.Value

For Each tempCell In Selection

If IsDate(tempCell) = True Then

With tempCell

.Value = Year(tempCell)

.NumberFormat = "0"

End With

End If

Next tempCell

End Sub

Coding VBA (Macro) Membuat Header dan Footer

Sub customHeader()

Dim myText As String

myText = InputBox("Enter your text here", "Enter Text")

With ActiveSheet.PageSetup

.LeftHeader = ""

.CenterHeader = myText

.RightHeader = ""

.LeftFooter = ""

.CenterFooter = ""

.RightFooter = ""

End With

End Sub

Coding VBA (Macro) Menghapus Karakter

Sub removeChar()

Dim Rng As Range

Dim rc As String

rc = InputBox("Character(s) to Replace", "Enter Value")

For Each Rng In Selection

Selection.Replace What:=rc, Replacement:=""

Next

End Sub

Coding VBA (Macro) Menghapus Desimal

Sub removeDecimals()

Dim lnumber As Double

Dim lResult As Long

Dim rng As Range

For Each rng In Selection

rng.Value= Int(rng)

rng.NumberFormat= "0"

Next rng

End Sub

Coding VBA (Macro) Mengunci /Proteksi Cell yang ada Formulanya

Sub lockCellsWithFormulas()

With ActiveSheet

.Unprotect

.Cells.Locked = False

.Cells.SpecialCells(xlCellTypeFormulas).Locked = True

.Protect AllowDeletingRows:=True

End With

End Sub

Coding VBA (Macro) Menampilkan tulisan A-Z dalam sekejap

Sub addcAlphabets()

Dim i As Integer

For i= 65 To 90

ActiveCell.Value= Chr(i)

ActiveCell.Offset(1, 0).Select

Next i

End Sub

Sub addsAlphabets()

Dim i As Integer

For i= 97 To 122

ActiveCell.Value= Chr(i)

ActiveCell.Offset(1, 0).Select

Next i

End Sub

Coding VBA (Macro) Menghapus Cell Kosong

Sub deleteBlankWorksheets()

Dim Ws As Worksheet

On Error Resume Next

Application.ScreenUpdating= False

Application.DisplayAlerts= False

For Each Ws In Application.Worksheets

If Application.WorksheetFunction.CountA(Ws.UsedRange) = 0 Then

Ws.Delete

End If

Next

Application.ScreenUpdating= True

Application.DisplayAlerts= True

End Sub

Coding VBA (Macro) Memberikan Tanda pada Data yang Dianggap Unik

Sub highlightUniqueValues()

Dim rng As Range

Set rng = Selection

rng.FormatConditions.Delete

Dim uv As UniqueValues

Set uv = rng.FormatConditions.AddUniqueValues

uv.DupeUnique = xlUnique

uv.Interior.Color = vbGreen

End Suba