Memilih Printer dengan VBA Excel

Menampilkan Kotak Dialog Printer, setelah dipilih akan ditampilkan di Range A1

Sub cetak()
Application.Dialogs(xlDialogPrinterSetup).Show

If Application.DisplayAlerts = False Then
    Exit Sub
Else
    Range("A1").Value = Application.ActivePrinter
End If

End Sub


Langsung Memilih Printer berdasarkan namanya

Sub pilihPrint()

Application.ActivePrinter = "CutePDF Writer on CPW2:"

End Sub

Mengetahui IP Address Komputer dengan VBA Excel

Option Explicit 
 
Sub IPtest() 
    Dim wsh As Object 
    Dim RegEx As Object, RegM As Object 
    Dim FSO As Object, fil As Object 
    Dim ts As Object, txtAll As String, TempFil As String 
    Set wsh = CreateObject("WScript.Shell") 
    Set FSO = CreateObject("Scripting.FileSystemObject") 
    Set RegEx = CreateObject("vbscript.regexp") 
    TempFil = "C:\myip.txt" 
     ' Save ipconfig info to temporary file
    wsh.Run "%comspec% /c ipconfig > " & TempFil, 0, True 
    With RegEx 
        .Pattern = "(\d{1,3}\.){3}\d{1,3}" 
        .Global = False 
    End With 
    Set fil = FSO.GetFile(TempFil) 
     ' Access temporary file
    Set ts = fil.OpenAsTextStream(1) 
    txtAll = ts.ReadAll 
    Set RegM = RegEx.Execute(txtAll) 
     ' Return IP address to Activesheet cell A1 by parsing text
    ActiveSheet.Range("A1").Value = RegM(0) 
    ActiveSheet.Range("A1").EntireColumn.AutoFit 
    ts.Close 
     ' Remove temp file
    Kill TempFil 
     
    Set ts = Nothing 
    Set wsh = Nothing 
    Set fil = Nothing 
    Set FSO = Nothing 
    Set RegM = Nothing 
    Set RegEx = Nothing 
End Sub 

Fungsi MaxIF dengan macro

Function maxIfs(maxRange As Range, criteriaRange As Range, criterion As Variant) As Variant

  maxIfs = Empty
  For i = 1 To maxRange.Cells.Count
    If criteriaRange.Cells(i).Value = criterion Then
        If maxIfs = Empty Then
            maxIfs = maxRange.Cells(i).Value
        Else
            maxIfs = Application.WorksheetFunction.Max(maxIfs, maxRange.Cells(i).Value)
        End If
    End If
  Next
End Function

Row Source Listbox di sheet yang lain

Contoh :

With lst_Barang
    .ColumnCount = 3
    .ColumnHeads = True
    .ColumnWidths = "40;140"
    .RowSource = Worksheets("db_Barang").Range(area).Address(external:=True)


End With












_

Fill dengan VBA/Macro

Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
        Step:=1, Stop:=10, Trend:=False
















_

Fungsi Terbilang (Bahasa Inggris)

    Dim Rupiahs, Cents, Temp
    Dim DecimalPlace, Count
    ReDim Place(9) As String
    Place(2) = " Thousand "
    Place(3) = " Million "
    Place(4) = " Billion "
    Place(5) = " Trillion "
    ' String representation of amount.
    MyNumber = Trim(Str(MyNumber))
    ' Position of decimal place 0 if none.
    DecimalPlace = InStr(MyNumber, ".")
    ' Convert cents and set MyNumber to dollar amount.
    If DecimalPlace > 0 Then
        Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & _
                  "00", 2))
        MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
    End If
    Count = 1
    Do While MyNumber <> ""
        Temp = GetHundreds(Right(MyNumber, 3))
        If Temp <> "" Then Rupiahs = Temp & Place(Count) & Rupiahs
        If Len(MyNumber) > 3 Then
            MyNumber = Left(MyNumber, Len(MyNumber) - 3)
        Else
            MyNumber = ""
        End If
        Count = Count + 1
    Loop
    Select Case Rupiahs
        Case ""
            Rupiahs = "Zero"
        Case "One"
            Rupiahs = "One Rupiah"
         Case Else
            Rupiahs = Rupiahs '& " Rupiahs"
    End Select
    Select Case Cents
        Case ""
            Cents = ""
        Case "One"
            Cents = " and One Cent"
              Case Else
            Cents = " and " & Cents & " Cents"
    End Select
    SpellNumber = Rupiahs & Cents
End Function
     
' Converts a number from 100-999 into text
Function GetHundreds(ByVal MyNumber)
    Dim Result As String
    If Val(MyNumber) = 0 Then Exit Function
    MyNumber = Right("000" & MyNumber, 3)
    ' Convert the hundreds place.
    If Mid(MyNumber, 1, 1) <> "0" Then
        Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
    End If
    ' Convert the tens and ones place.
    If Mid(MyNumber, 2, 1) <> "0" Then
        Result = Result & GetTens(Mid(MyNumber, 2))
    Else
        Result = Result & GetDigit(Mid(MyNumber, 3))
    End If
    GetHundreds = Result
End Function
     
' Converts a number from 10 to 99 into text.
Function GetTens(TensText)
    Dim Result As String
    Result = ""           ' Null out the temporary function value.
    If Val(Left(TensText, 1)) = 1 Then   ' If value between 10-19...
        Select Case Val(TensText)
            Case 10: Result = "Ten"
            Case 11: Result = "Eleven"
            Case 12: Result = "Twelve"
            Case 13: Result = "Thirteen"
            Case 14: Result = "Fourteen"
            Case 15: Result = "Fifteen"
            Case 16: Result = "Sixteen"
            Case 17: Result = "Seventeen"
            Case 18: Result = "Eighteen"
            Case 19: Result = "Nineteen"
            Case Else
        End Select
    Else                                 ' If value between 20-99...
        Select Case Val(Left(TensText, 1))
            Case 2: Result = "Twenty "
            Case 3: Result = "Thirty "
            Case 4: Result = "Forty "
            Case 5: Result = "Fifty "
            Case 6: Result = "Sixty "
            Case 7: Result = "Seventy "
            Case 8: Result = "Eighty "
            Case 9: Result = "Ninety "
            Case Else
        End Select
        Result = Result & GetDigit _
            (Right(TensText, 1))  ' Retrieve ones place.
    End If
    GetTens = Result
End Function
   
' Converts a number from 1 to 9 into text.
Function GetDigit(Digit)
    Select Case Val(Digit)
        Case 1: GetDigit = "One"
        Case 2: GetDigit = "Two"
        Case 3: GetDigit = "Three"
        Case 4: GetDigit = "Four"
        Case 5: GetDigit = "Five"
        Case 6: GetDigit = "Six"
        Case 7: GetDigit = "Seven"
        Case 8: GetDigit = "Eight"
        Case 9: GetDigit = "Nine"
        Case Else: GetDigit = ""
    End Select
End Function

Fungsi Terbilang (Indonesia)

Function Terbilang(n As Long) As String 'max 2.147.483.647
Dim satuan As Variant, Minus As Boolean
On Error GoTo terbilang_error
satuan = Array("", "Satu", "Dua", "Tiga", "Empat", "Lima", "Enam", "Tujuh", "Delapan", "Sembilan", "Sepuluh", "Sebelas")
If n < 0 Then
Minus = True
n = n * -1
End If
Select Case n
Case 0 To 11
Terbilang = " " + satuan(Fix(n))
Case 12 To 19
Terbilang = Terbilang(n Mod 10) + " Belas"
Case 20 To 99
Terbilang = Terbilang(Fix(n / 10)) + " Puluh" + Terbilang(n Mod 10)
Case 100 To 199
Terbilang = " Seratus" + Terbilang(n - 100)
Case 200 To 999
Terbilang = Terbilang(Fix(n / 100)) + " Ratus" + Terbilang(n Mod 100)
Case 1000 To 1999
Terbilang = " Seribu" + Terbilang(n - 1000)
Case 2000 To 999999
Terbilang = Terbilang(Fix(n / 1000)) + " Ribu" + Terbilang(n Mod 1000)
Case 1000000 To 999999999
Terbilang = Terbilang(Fix(n / 1000000)) + " Juta" + Terbilang(n Mod 1000000)
Case Else
Terbilang = Terbilang(Fix(n / 1000000000)) + " Milyar" + Terbilang(n Mod 1000000000)
End Select
If Minus = True Then
Terbilang = "Minus" + Terbilang
End If
Exit Function
terbilang_error:
MsgBox Err.Description, vbCritical, "^_^Terbilang Error"
End Function

Membuat Nama Cell dengan VBA Excel

Range("=Master!$L$2:OFFSET(Master!$L$2,COUNT(Master!$L$2:$L$1048576)-1,5)").Name = "DATA_CUST"

Report PDF

Sub rpt_pdf()
Dim lokasifileTemp As String
Dim namafolderTemp As String

lokasifileTemp = ActiveWorkbook.Path
namafolderTemp = lokasifileTemp & "\rpt_Temp"

If Len(Dir(namafolderTemp, vbDirectory)) = 0 Then
   MkDir namafolderTemp
End If

Sheets("Olah Laporan").Select
Dim namawb As String
Dim noNIK As String
namasheet = Sheet3.Range("F39").Value
namawb = ActiveWorkbook.Path & "\rpt_Temp\" & Sheet3.Range("F39").Value & "_" & Format(Now, "yymmddhhmmss") & ".pdf"

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
        namawb, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        True
       
Exit Sub


    Sheets("Olah Laporan").Copy
   
    ActiveWorkbook.SaveAs FileName:=namawb, FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
    Sheets("Olah Laporan").Select
    Sheets("Olah Laporan").Name = namasheet
   
    ActiveWorkbook.Save
    ActiveWindow.Close
   
    Dim appXL As New Excel.Application
   
    appXL.Workbooks.Open namawb
    appXL.Visible = True
End Sub

Report HTML

Sub rpt_HTML()

Dim lokasifileTemp As String
Dim namafolderTemp As String

lokasifileTemp = ActiveWorkbook.Path
namafolderTemp = lokasifileTemp & "\rpt_Temp"

If Len(Dir(namafolderTemp, vbDirectory)) = 0 Then
   MkDir namafolderTemp
End If


Sheets("Olah Laporan").Select
Dim namawbHTML As String

namasheetHTML = Sheet3.Range("F39").Value
namawbHTML = ActiveWorkbook.Path & "\rpt_Temp\" & Sheet3.Range("F39").Value & "_" & Format(Now, "yymmddhhmmss") & ".htm"
    Sheets("Olah Laporan").Copy

Sheets("Olah Laporan").Select
    Sheets("Olah Laporan").Name = namasheetHTML
   
 ActiveWorkbook.SaveAs FileName:= _
        namawbHTML, FileFormat:=xlHtml, _
        ReadOnlyRecommended:=False, CreateBackup:=False
       
   
   
    ActiveWorkbook.Save
    ActiveWindow.Close

       
Dim HyperHTML As String
HyperHTML = namawbHTML
    ThisWorkbook.FollowHyperlink address:=HyperHTML ', NewWindow:=True

End Sub

Report Excel

Sub rpt_excel()
Dim lokasifileTemp As String
Dim namafolderTemp As String

lokasifileTemp = ActiveWorkbook.Path
namafolderTemp = lokasifileTemp & "\rpt_Temp"

If Len(Dir(namafolderTemp, vbDirectory)) = 0 Then
   MkDir namafolderTemp
End If

Sheets("Olah Laporan").Select
Dim namawb As String
Dim noNIK As String
namasheet = Sheet3.Range("F39").Value
namawb = ActiveWorkbook.Path & "\rpt_Temp\" & Sheet3.Range("F39").Value & "_" & Format(Now, "yymmddhhmmss") & ".xlsx"
    Sheets("Olah Laporan").Copy
   
    ActiveWorkbook.SaveAs FileName:=namawb, FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
    Sheets("Olah Laporan").Select
    Sheets("Olah Laporan").Name = namasheet
   
    ActiveWorkbook.Save
    ActiveWindow.Close
   
    Dim appXL As New Excel.Application
   
    appXL.Workbooks.Open namawb
    appXL.Visible = True
End Sub

VlookUp Query SQL pada VBA Excel

Sub VlookupCOA()

Call Koneksi

SqlQueryString = "SELECT Nama_SL FROM SL WHERE No_SL = " & frm_JU.txt_COA.Text
Set rs = New ADODB.Recordset

rs.Open SqlQueryString, cnAccess, adOpenForwardOnly, adLockOptimistic

If Not rs.BOF Then
    frm_JU.txt_NamaCOA.Text = rs("Nama_SL")
   
Else
    MsgBox "COA tidak terdaftar", vbCritical, "Info"
    frm_JU.txt_NamaCOA.Text = ""
    frm_JU.txt_COA.Text = ""
End If


rs.Close
Set rs = Nothing
End Sub

Membuat Trusted Locations dengan VBA Excel

Sub AddPathToTrustedLocations()
  Const strMsg = "Do you want to add the path of this workbook " & _
    "to your Trusted Locations?"
  Const strReg = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & _
    "12.0\Excel\Security\Trusted Locations\ABabeNChrist\"
  Dim objShell As Object
  Dim strValue As String
  Dim strPath As String
  Set objShell = CreateObject("WScript.Shell")
  strPath = ActiveWorkbook.Path
  On Error Resume Next
  strValue = objShell.RegRead(strReg & "Path")
  On Error GoTo 0
  'If strValue <> strPath Then
    'If MsgBox(strMsg, vbQuestion + vbYesNo) = vbYes Then
      objShell.RegWrite strReg & "Path", strPath, "REG_SZ"
    'End If
  'End If
  Set objShell = Nothing
End Sub

Jika hasil query SQL Null

maxno = IIf(IsNull(rs.Fields(0)) = True, 0, rs.Fields(0))

Format Mata Uang di textbox

Private Sub txt_Koli_Exit(ByVal Cancel As MSForms.ReturnBoolean)

With Me.txt_Koli

    If IsNumeric(.Value) Then
        dblNum = .Value
        .Value = Format(dblNum, "#,##0.00")
    Else ': MsgBox "Silahkan masukkan nilai angka", , "Info"
        .Text = vbNullString
     
    End If

End With

End Sub

Delete Baris

Selection.Delete Shift:=xlUp

Agar Textbox hanya angka

Private Sub txt_tglTrx_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)

If Not (KeyAscii >= Asc("0") And KeyAscii <= Asc("9") _
   Or KeyAscii = vbKeyBack Or KeyAscii = vbKeyReturn) Then
    Beep
    KeyAscii = 0

End If

End Sub

WorksheetFunction.Match pada VBA Excel

Public Sub test()
    Dim rng As Range
    Dim aNumber As Variant
    Dim rowNum As Long

    aNumber = "2gg"

    Set rng = Sheet5.Range("B1:B20")

    If Not IsError(Application.Match(aNumber, rng, 0)) Then
        rowNum = Application.Match(aNumber, rng, 0)
        MsgBox rowNum
    Else
        MsgBox "error"
    End If
End Sub

atau

Public Sub test()
    Dim rng As Range
    Dim aNumber As Variant
    Dim rowNum As Variant

    aNumber = "2gg"

    Set rng = Sheet5.Range("B1:B20")

    rowNum = Application.Match(aNumber, rng, 0)

    If Not IsError(rowNum) Then
        MsgBox rowNum
    Else
        MsgBox "error"
    End If
End Sub



Referensi
http://stackoverflow.com/questions/20214540/application-worksheetfunction-match-method





_

WorksheetFunction.CountIf pada VBA Excel

Public Sub test()

Dim rng As Range
Dim aNumber As Long

aNumber = 666

Set rng = Sheet5.Range("B16:B615")

    If Application.WorksheetFunction.CountIf(rng, aNumber) > 0 Then

        rowNum = Application.WorksheetFunction.Match(aNumber, rng, 0)

    Else
        MsgBox aNumber & " does not exist in range " & rng.Address
    End If

End Sub


Referensi
http://stackoverflow.com/questions/20214540/application-worksheetfunction-match-method





_

Delete Folder

Sub delete_folder()
    Dim Fs As Object
    Dim alamatfolder As String
   
    On Error GoTo DelErr
    Set Fs = CreateObject("Scripting.FileSystemObject")
    alamatfolder = ActiveWorkbook.Path & "\rpt_Temp"
   
    Fs.DeleteFolder alamatfolder, True
   
    Exit Sub
DelErr:
        Exit Sub
'    MsgBox Err.Number & vbCr & _
'    Err.Description
End Sub