Custom Function untuk Excel

March 29, 2009 at 4:27 pm Leave a comment

Berikut adalah contoh custom function untuk excel.

untuk melihat semua fungsi dan contoh pemakaiannya  download file excel custom function di sini :

Fungsi terdiri dari :

Function HasFormula(TargetCell)
‘ Returns TRUE if Target Cell has formula
HasFormula = TargetCell.HasFormula
End Function

Function GetFormula(TargetCell As Range, Optional FormatNumber As Variant) As String
‘ Returns formula used in Target Cell
If IsMissing(FormatNumber) Then
GetFormula = TargetCell.FormulaLocal
Else
GetFormula = TargetCell.FormatConditions(FormatNumber).Formula1
End If
End Function

Function GetFormat(TargetCell As Range) As String
‘ Returns format used in Target Cell
GetFormat = TargetCell.NumberFormat
End Function

Function GetFont(TargetCell As Range) As String
‘ Returns font name and size used in Target Cell
GetFont = TargetCell.Font.Name & ” ” & TargetCell.Font.Size
End Function

Function GetComment(TargetCell As Range) As String
‘ Returns text from comment in Target Cell
GetComment = TargetCell.Comment.Text
End Function

Function SheetsName() As String
‘ Returns Active Sheet’s name
SheetsName = ActiveSheet.Name
End Function

Function BooksName() As String
‘ Returns Active Workbook’s name
BooksName = ActiveWorkbook.Name
End Function

Function FullName() As String
‘ Returns Active Workbook’s full name (includes directory)
FullName = ActiveWorkbook.FullName
End Function

Function UsersName() As String
‘ Returns the user’s name
UsersName = Application.UserName
End Function

Function RowSize(Optional TargetCell As Variant)
‘ Returns Row Height of Active Cell if no range (Target Cell) is specified
If IsMissing(TargetCell) Then
RowSize = ActiveCell.RowHeight
Else
RowSize = TargetCell.RowHeight
End If
End Function

Function ColumnSize(Optional TargetCell As Variant)
‘ Returns Column Width of Active Cell if no range (Target Cell) is specified
If IsMissing(TargetCell) Then
ColumnSize = ActiveCell.ColumnWidth
Else
ColumnSize = TargetCell.ColumnWidth
End If
End Function

Function FirstinRow(myRow As Range)
‘ Returns the First Value in the row specified
If Cells(myRow.Row, 1) <> “” Then FirstinRow = Cells(myRow.Row, 1).Value
If Cells(myRow.Row, 1) = “” Then FirstinRow = Cells(myRow.Row, 1).End(xlToRight).Value
End Function

Function FirstinColumn(myColumn As Range)
‘ Returns the First Value in the column specified
If Cells(1, myColumn.Column) <> “” Then FirstinColumn = Cells(1, myColumn.Column).Value
If Cells(1, myColumn.Column) = “” Then FirstinColumn = Cells(1, myColumn.Column).End(xlDown).Value
End Function

Function LastinRow(myRow As Range)
‘ Returns the Last Value in the row specified
If Cells(myRow.Row, 256) <> “” Then LastinRow = Cells(myRow.Row, 256).Value
If Cells(myRow.Row, 256) = “” Then LastinRow = Cells(myRow.Row, 256).End(xlToLeft).Value
End Function

Function LastinColumn(myColumn As Range)
‘ Returns the Last Value in the column specified
If Cells(65536, myColumn.Column) <> “” Then LastinColumn = Cells(65536, myColumn.Column).Value
If Cells(65536, myColumn.Column) = “” Then LastinColumn = Cells(65536, myColumn.Column).End(xlUp).Value
End Function

Function Millions(TargetCell As Range) As String
‘ Round numbers up to millions as in “10 Million”, recommended maximum of 15 Digits
‘ (A custom format of #,##0,, can also be used)
If TargetCell.Value / 1000000 < 1 Then Millions = “” _
Else If Int(TargetCell.Value / 1000000) Mod 1000 = 0 Then Millions = “” _
Else Millions = Int(TargetCell.Value / 1000000) Mod 1000 & ” Million”
End Function

Function Thousands(TargetCell As Range) As String
‘ Round numbers up to thousands as in “10 Thousand”, recommended maximum of 12 Digits
‘ (A custom format of #,##0, can also be used)
If TargetCell.Value / 1000 < 1 Then Thousands = “” _
Else If Int(TargetCell.Value / 1000) Mod 1000 = 0 Then Thousands = “” _
Else Thousands = Int(TargetCell.Value / 1000) Mod 1000 & ” Thousand”
End Function

Function GetNumbers(TargetCell As Range) As String
‘ Returns numbers as string and retains leading zeros (all text is removed)
‘ Use double negative for real numbers as in –GetNumbers(Target Cell As Range)
‘ Leading zeros will be lost with real numbers unless formatted accordingly
‘ See http://www.andrewsexceltips.com/menu_formats_zeros_front_numbers.htm
Dim LenStr As Long
For LenStr = 1 To Len(TargetCell)
Select Case Asc(Mid(TargetCell, LenStr, 1))
Case 48 To 57
GetNumbers = GetNumbers & Mid(TargetCell, LenStr, 1)
End Select
Next
End Function

Function GetText(TargetCell As Range) As String
‘ Returns capital or small letters only (all numbers are removed)
Dim LenStr As Long
For LenStr = 1 To Len(TargetCell)
Select Case Asc(Mid(TargetCell, LenStr, 1))
Case 65 To 90
GetText = GetText & Mid(TargetCell, LenStr, 1)
Case 97 To 122
GetText = GetText & Mid(TargetCell, LenStr, 1)
End Select
Next
End Function

Function HasText(TargetCell1 As Range, TargetCell2 As Range) As Boolean
‘ Returns TRUE if text or numbers in second Target Cell are contained in first Target Cell
If Not Application.Substitute(TargetCell1, TargetCell2, “”) = TargetCell1 Then HasText = True
End Function

Function ReverseText(TargetCell) As String
‘ Reverses Text of Target Cell
Dim LenStr As Long
For LenStr = Len(TargetCell) To 1 Step -1
ReverseText = ReverseText & Mid(TargetCell, LenStr, 1)
Next
End Function

Function GetColorIndex(TargetCell As Range, Optional CondFormat As Variant)
‘ Returns the color index of the Target Cell. Use Optional CondFormat 1, 2 or 3 for Conditional Formatting.
‘ “No Fill Color” or “0” will show if there is no color.
On Error Resume Next
Application.Volatile
Select Case CondFormat
Case IsMissing(CondFormat)
GetColorIndex = TargetCell.Interior.ColorIndex
Case 1
GetColorIndex = TargetCell.FormatConditions(1).Interior.ColorIndex
Case 2
GetColorIndex = TargetCell.FormatConditions(2).Interior.ColorIndex
Case 3
GetColorIndex = TargetCell.FormatConditions(3).Interior.ColorIndex
End Select
If GetColorIndex < 1 Then GetColorIndex = “No Fill Color”
End Function

Function GetFontIndex(TargetCell As Range, Optional CondFormat As Variant)
‘ Returns the font color index of the Target Cell. Use Optional CondFormat 1, 2 or 3 for Conditional Formatting.
‘ Will not work with Number Formats
On Error Resume Next
Application.Volatile
Select Case CondFormat
Case IsMissing(CondFormat)
GetFontIndex = TargetCell.Font.ColorIndex
Case 1
GetFontIndex = TargetCell.FormatConditions(1).Font.ColorIndex
Case 2
GetFontIndex = TargetCell.FormatConditions(2).Font.ColorIndex
Case 3
GetFontIndex = TargetCell.FormatConditions(3).Font.ColorIndex
End Select
If GetFontIndex < 0 Then GetFontIndex = “Automatic”
End Function

Function ColorName(TargetCell As Range, Optional CondFormat As Variant)
‘ Returns the color name of the Target Cell. Use Optional CondFormat 1, 2 or 3 for Conditional Formatting.
‘ A blank or #NA will show in the case of an error
On Error Resume Next
Application.Volatile
Dim ColIndex As Variant, ColName As Variant
ColIndex = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, _
29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56)
ColName = Array(“”, “Black”, “White”, “Red”, “Bright Green”, “Blue”, “Yellow”, “Pink”, “Turquoise”, _
“Dark Red”, “Green”, “Dark Blue”, “Dark Yellow”, “Violet”, “Teal”, “Gray-25%”, “Gray-50%”, “Periwinkle”, _
“Plum”, “Ivory”, “Light Turquoise”, “Dark Purple”, “Coral”, “Ocean Blue”, “Ice Blue”, “Dark Blue”, “Pink”, _
“Yellow”, “Turquoise”, “Violet”, “Dark Red”, “Green”, “Blue”, “Sky Blue”, “Light Turquoise”, “Light Green”, _
“Light Yellow”, “Pale Blue”, “Rose”, “Lavender”, “Tan”, “Light Blue”, “Aqua”, “Lime”, “Gold”, “Light Orange”, _
“Orange”, “Blue-Gray”, “Gray-40%”, “Dark Teal”, “Sea Green”, “Dark Green”, “Olive Green”, “Brown”, _
“Plum”, “Indigo”, “Gray-80%”)
Select Case CondFormat
Case IsMissing(CondFormat)
ColorName = Application.Match(TargetCell.Interior.ColorIndex, ColIndex, 0)
Case 1
ColorName = Application.Match(TargetCell.FormatConditions(1).Interior.ColorIndex, ColIndex, 0)
Case 2
ColorName = Application.Match(TargetCell.FormatConditions(2).Interior.ColorIndex, ColIndex, 0)
Case 3
ColorName = Application.Match(TargetCell.FormatConditions(3).Interior.ColorIndex, ColIndex, 0)
End Select
ColorName = ColName(ColorName)
End Function

Function GetHTMLColor(TargetCell As Range)
‘ Returns HTML Color of Target Cell
‘ It will not work with Conditional Formatting
Application.Volatile
Dim myColor As String
Dim HTMLcolor As String
myColor = Right(“000000″ & Hex(TargetCell.Interior.Color), 6)
GetHTMLColor = “#” & Right(myColor, 2) & Mid(myColor, 3, 2) & Left(myColor, 2)
End Function

Function CountColor(TargetCells As Range, ColorInd As Byte) As Long
‘ Counts all cells of the color specified (ColorInd = Color Index)
‘ It will not work with Conditional Formatting
Application.Volatile
Dim rangeCell As Range
For Each rangeCell In TargetCells
If rangeCell.Interior.ColorIndex = ColorInd Then CountColor = CountColor + 1
Next
End Function

Function SumColor(TargetCells As Range, ColorInd As Byte) As Long
‘ Sums values in all cells of the color specified (ColorInd = Color Index)
‘ It will not work with Conditional Formatting
Application.Volatile
Dim rangeCell As Range
For Each rangeCell In TargetCells
If rangeCell.Interior.ColorIndex = ColorInd Then SumColor = SumColor + rangeCell.Value
Next
End Function

Function DateFormat(TargetCell As Range, Optional ChooseFormat As Long)
‘ Select a number to change format of Target Cell or decline to retain same format as Target Cell
Select Case ChooseFormat
Case IsMissing(ChooseFormat)
DateFormat = Format(TargetCell, TargetCell.NumberFormatLocal)
Case 1
DateFormat = Format(TargetCell, “dd/mm/yy”)
Case 2
DateFormat = Format(TargetCell, “mm/dd/yy”)
Case 3
DateFormat = Format(TargetCell, “d mmmm, yyyy”)
Case 4
DateFormat = Format(TargetCell, “mmmm d, yyyy”)
End Select
End Function

Function DateFormat2(TargetDate As Date, ChooseFormat As Long)
‘ Select a number to change format of TargetDate, can be used with TODAY, NOW or dates entered with commas
Select Case ChooseFormat
Case 1
DateFormat2 = Format(TargetDate, “dd/mm/yy”)
Case 2
DateFormat2 = Format(TargetDate, “mm/dd/yy”)
Case 3
DateFormat2 = Format(TargetDate, “d mmmm, yyyy”)
Case 4
DateFormat2 = Format(TargetDate, “mmmm d, yyyy”)
End Select
End Function

Function EDatePlus(MyDate As Date, Months As Long) As Date
‘ Works as an alternative to the EDATE function fron the Analysis Toolpak
If Day(MyDate) <> Day(DateSerial(Year(MyDate), Month(MyDate) + Months, Day(MyDate))) _
Then EDatePlus = DateSerial(Year(MyDate), Month(MyDate) + Months + 1, 0) _
Else EDatePlus = DateSerial(Year(MyDate), Month(MyDate) + Months, Day(MyDate))
End Function

Function EOMonthPlus(MyDate As Date, Months As Long) As Date
‘ Works as an alternative to the EOMONTH function fron the Analysis Toolpak
EOMonthPlus = DateSerial(Year(MyDate), Month(MyDate) + Months + 1, 0)
End Function

Function LastDate(MyYear As Long, MyMonth As Long, MyDay As Long) As Date
‘ Returns Last Date of a Month specified by MyDay (Sunday = 1, Monday = 2, Tuesday = 3 etc)
If MyMonth <> Month(DateSerial(MyYear, MyMonth + 1, 0) – (Weekday(DateSerial(MyYear, MyMonth + 1, 0)) – MyDay)) _
Then LastDate = DateSerial(MyYear, MyMonth + 1, 0) – (Weekday(DateSerial(MyYear, MyMonth + 1, 0)) – MyDay) – 7 _
Else LastDate = DateSerial(MyYear, MyMonth + 1, 0) – (Weekday(DateSerial(MyYear, MyMonth + 1, 0)) – MyDay)
End Function

Function StatRand()
‘ Returns static random numbers (similar to RAND)
Static myValue
myValue = Rnd
StatRand = myValue
End Function

Function StatRandBetween(UpperValue As Single, LowerValue As Single)
‘ Returns static random numbers between values specified (similar to RANDBETWEEN)
Static myValue
myValue = Int((UpperValue – LowerValue + 1) * Rnd + LowerValue)
StatRandBetween = myValue
End Function

Function Chain(TargetCells As Range, Optional Separator As Variant) As String
‘ Original VBA by Masaru Kaji aka Colo, Colo’s Junk Room,http://www.puremis.net/excel
‘ Concatenates (Joins) numbers or text together, with or without separators
‘ Separators must be enclosed by quotation marks as in “-” etc.
‘ Mid(Chain, Len(Separator) + 1) suggested by Joerd, ( was Mid(Chain, 2) )
Dim Str As Range
If IsMissing(Separator) Then
For Each Str In TargetCells
Chain = Chain & Str.Value
Next
Else
For Each Str In TargetCells
Chain = Chain & Separator & Str.Value
Next
Chain = Mid(Chain, Len(Separator) + 1)
End If
End Function

About these ads

Entry filed under: Ms Excel, Resources, Tips, VBA, Vba Excel. Tags: , , , , .

Menampilkan Pesan Pada Workbook Economic Order Quantity dengan Excel

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

Trackback this post  |  Subscribe to the comments via RSS Feed


Enter your email address to subscribe to this blog and receive notifications of new posts by email.

Join 14 other followers

Blog Stats

  • 78,355 hits

Twitter Updates

Error: Twitter did not respond. Please wait a few minutes and refresh this page.

Iklan


Follow

Get every new post delivered to your Inbox.

%d bloggers like this: