Kursus Excel Online

'---Connect to the Workbook---
Set cn = CreateObject("ADODB.Connection")
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
.Open
End With

'---Running the SQL Select Query---

Sql = "SELECT '', AgentName, Pax, SellingFare, Pax * SellingFare, 455, 455 * Pax FROM [db_SALES$] WHERE Trx = 'Selling' AND FlightDateGo = #" & TglTerbang & "#"

Set rs = cn.Execute(Sql)
'Sheets("Report").Range("A2").CopyFromRecordset rs

' Do
' output = output & rs(0) & ";" & rs(1) & ";" & rs(2) & vbNewLine
' Debug.Print rs(0); ";" & rs(1) & ";" & rs(2)
' rs.Movenext
' Loop Until rs.EOF
' MsgBox output

'---Clean up---

rs.Close
cn.Close
Set cn = Nothing
Set rs = Nothing

MEMBUAT PESAN JIKA QUERY TIDAK TERSEDIA DENGAN BAHASA SQL

| |

If rs.BOF And rs.EOF Then
MsgBox "User tidak terdaftar", , "Info"
txt_user.SetFocus
Exit Sub
End If

LISTBOX DINAMIS DENGAN BAHASA SQL

| |

jlhdata = WorksheetFunction.CountA(Sheets("db_Customer").Range("A2:A1048576"))

Select Case jlhdata
Case Is > 0
area = "A2:D" & jlhdata + 1
frm_CustomerData.lst_data.Enabled = True
Case 0
area = "A2:D2"
frm_CustomerData.lst_data.Enabled = False
End Select

With frm_CustomerData.lst_data
.ColumnCount = 4
.ColumnHeads = True
.ColumnWidths = "100;150;220;100"
.RowSource = Worksheets("db_Customer").Range(area).Address(external:=True)
End With

PILIH DATA DENGAN BAHASA SQL

| |

Call Koneksi

SqlQueryString = "SELECT * FROM SA"
Set rs = New ADODB.Recordset

rs.Open SqlQueryString, cnAccess, adOpenForwardOnly, adLockOptimistic

'Display Judul
Dim j As Integer
For j = 0 To rs.Fields.Count - 1
With Worksheets("Data2")
.Cells(1, j + 1) = rs.Fields(j).Name
.Cells(1, j + 1).Font.Bold = True
.Cells(1, j + 1).Interior.ColorIndex = 15

.Range("A2").CopyFromRecordset rs
.Columns("A:Z").AutoFit
End With
Next j

rs.Close
Set rs = Nothing

SUMPRODUK HPP

| |

=IF(SUMIFS(S8_Jumlah,S8_Mutasi,"M",S8_KodeBrg,$AA4)=0,0,(ROUND(SUMPRODUCT(S8_Jumlah,S8_HargaSatuan,--(S8_Mutasi="M"),--(S8_KodeBrg=DataPerlengkapan!$AA4))/SUMIFS(S8_Jumlah,S8_Mutasi,"M",S8_KodeBrg,$AA4),0)))

VERSI MACRO NYA
Sheet9.Range("AH4").Formula = "=IF(SUMIFS(S8_Jumlah,S8_Mutasi,""M"",S8_KodeBrg,$AA4)=0,0,(ROUND(SUMPRODUCT(S8_Jumlah,S8_HargaSatuan,--(S8_Mutasi=""M""),--(S8_KodeBrg=DataPerlengkapan!$AA4))/SUMIFS(S8_Jumlah,S8_Mutasi,""M"",S8_KodeBrg,$AA4),0)))"

__

SORTIR DENGAN MACRO

| |

Sub sortDB()

Sheet3.Select
Range("A2:Z2").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("db").AutoFilter.Sort.SortFields. _
Clear

ActiveWorkbook.Worksheets("db").AutoFilter.Sort.SortFields. _
Add Key:=Range("B2"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal

ActiveWorkbook.Worksheets("db").AutoFilter.Sort.SortFields. _
Add Key:=Range("C2"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal

ActiveWorkbook.Worksheets("db").AutoFilter.Sort.SortFields. _
Add Key:=Range("D2"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal

With ActiveWorkbook.Worksheets("db").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Selection.AutoFilter
End Sub

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

| | Label: Fungsi VBA Excel

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

| | Label: Fill, Macro, VBA Excel

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

_

Fungsi Terbilang (Bahasa Inggris)

| | Label: Fungsi VBA Excel, Macro, Macro Excel, VBA Excel

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)

| | Label: Fungsi VBA Excel, Macro Excel, VBA Excel

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

Pages