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