Các hàm worksheet hay của PUP

[levanduyet]

Các hàm worksheet hay của PUP_Các bác kế toán nên biết

Phần I
HÃY CÙNG KHÁM PHÁ CÁC HÀM CỦA POP

Đa số các hàm này Tác giả đều có đề cập trong sách:
Microsoft Excel 2000 Power Programming with VBA
Đây là đọan mã của các hàm

Function CELLCOLORINDEX(Cell) As Long
' Returns a number that corresponds to a cell''s background color
' Trả về số đại diện cho màu nền của cell
CELLCOLORINDEX = Cell(1).Interior.ColorIndex
End Function
Function CELLFONTCOLOR(Cell) As Variant
' Tương tự trả về màu của font
CELLFONTCOLOR = Cell(1).Font.ColorIndex
End Function
Function CELLHASFORMULA(Cell) As Boolean
' Returns TRUE if cell has a formula
' Trả về TRUE nếu cell có công thức
CELLHASFORMULA = Cell(1).HasFormula
End Function
Function CELLTYPE(Cell)
' Returns the cell type of the upper left cell in a range
' Trả về chuổi mô tả kiểu dữ liệu của cell
Select Case True
Case Cell(1).NUMBERFORMAT = "@"
CELLTYPE = "Text"
Case IsEmpty(Cell(1))
CELLTYPE = "Blank"
Case WorksheetFunction.IsText(Cell(1))
CELLTYPE = "Text"
Case WorksheetFunction.IsLogical(Cell(1))
CELLTYPE = "Logical"
Case WorksheetFunction.IsErr(Cell(1))
CELLTYPE = "Error"
Case IsDate(Cell(1))
CELLTYPE = "Date"
Case InStr(1, Cell(1).text, ":") <> 0
CELLTYPE = "Time"
Case IsNumeric(Cell(1))
CELLTYPE = "Value"
End Select
End Function
Function CONTAINS(text1 As String, text2 As String, Optional casesensitive) As Boolean
' Returns True if text2 is contained in text1
' Trả về True nếu text2 nằm trong text1
If text1 = "" Or text2 = "" Then
CONTAINS = Evaluate("NA()")
Exit Function
End If
If IsMissing(casesensitive) Then casesensitive = 0
Select Case casesensitive
Case 0 ''zero or missing
If text2 Like "*" & text1 & "*" Then CONTAINS = True Else CONTAINS = False
Case Else ''any non-zero 3rd argument
If UCase(text2) Like "*" & UCase(text1) & "*" Then CONTAINS = True Else CONTAINS = False
End Select
End Function
Function COUNTAVISIBLE(ParamArray number())
' Returns the count of visible cells in a range
' Đếm số cell visible trong range
Dim Cell As Range, i As Long
Application.Volatile
COUNTAVISIBLE = 0
For i = 0 To UBound(number)
If Not IsError(number(i)) Then
If TypeName(number(i)) = "Range" Then
Set number(i) = Intersect(number(i).Parent.UsedRange, number(i))
For Each Cell In number(i)
If Not Cell.EntireRow.Hidden And Not Cell.EntireColumn.Hidden Then COUNTAVISIBLE = COUNTAVISIBLE + Evaluate(Application.CountA(Cell))
Next Cell
Else
COUNTAVISIBLE = COUNTAVISIBLE + Evaluate(Application.CountA(number(i)))
End If
End If
Next i
End Function
Function COUNTBETWEEN(Rng, num1, num2) As Long
' Counts number of values between num1 and num2
' Đếm số giá trị giữa num1 và num2
Dim Cell As Range
Dim Low As Double, Hi As Double
Low = Application.Min(num1, num2)
Hi = Application.Max(num1, num2)
Set Rng = Intersect(Rng.Parent.UsedRange, Rng)
COUNTBETWEEN = 0
If Rng Is Nothing Then Exit Function
COUNTBETWEEN = Application.CountIf(Rng, ">=" & Low) - Application.CountIf(Rng, ">" & Hi)
End Function
Function CREDITCARD(Num As String) As String
' Hàm này thường ít sử dụng
Dim i As Long, CheckSum As Long, Prod As Long
Dim CardType As String
Const MASK As String = "2121212121212121"
' Remove dashes and spaces
Num = Replace(Num, "-", "")
Num = Replace(Num, " ", "")
' Determine card type
CardType = "Unknown"
If Left(Num, 2) = "37" Then CardType = "AmEx"
If Left(Num, 1) = "4" Then CardType = "Visa"
If Left(Num, 1) = "5" Then CardType = "MasterCard"
If Left(Num, 1) = "6" Then CardType = "Discover"
' Make card length = 16
Select Case Len(Num)
Case 13: Num = "000" & Num
Case 14: Num = "00" & Num
Case 15: Num = "0" & Num
Case 16: Num = Num
Case Else
CREDITCARD = "Invalid"
Exit Function
End Select
' Calculate check sum
CheckSum = 0
For i = 1 To 16
Prod = Mid(Num, i, 1) * Mid(MASK, i, 1)
If Prod > 9 Then Prod = Prod - 9
CheckSum = CheckSum + Prod
Next i
CheckSum = CheckSum Mod 10
If CheckSum <> 0 Then CREDITCARD = "Invalid" Else CREDITCARD = CardType
End Function
Function DAYSINMONTH(serial_number As Date) As Long
' Returns the number of days in the month for a date
' Trả về số ngày trong một tháng
Dim m As Long, y As Long
m = Month(serial_number)
y = Year(serial_number)
If m = 12 Then
m = 1
y = y + 1
Else
m = m + 1
End If
DAYSINMONTH = Day(DateSerial(y, m, 1) - 1)
End Function
Function DOLLARTEXT(number, Optional units) As String
'Chuyển số thành chữ
'Used in the Power Utility Pak with the kind permission of Steven Mark
'CopyrightC)1996-2002 On-The-Mark Systems, Danville, CA
'Author: Steven Mark, On-The-Mark Systems,
'Email: steve@otms.com
'Web: http://www.otms.com
Dim strEntireNumber As String
Dim cbEntireNumber As Long
Dim strOut As String
Dim iPos As Long
Dim nHundreds As Long
Dim nTens As Long
Dim nOnes As Long
Dim nTensOnes As Long
Dim astrUnits(17) As String
Dim strLast As String
''Ensure this is a number
If Not IsNumeric(number) Then
Exit Function
End If
''Format the number
strEntireNumber = Format(number, "###0.00")
cbEntireNumber = Len(strEntireNumber)
If cbEntireNumber > 18 Then
DOLLARTEXT = CVErr(xlErrNum)
Exit Function
End If
''Do it
strOut = ""
strLast = ""
astrUnits(17) = "Trillion"
astrUnits(14) = "Billion"
astrUnits(11) = "Million"
astrUnits(8) = "Thousand"
For iPos = 17 To 5 Step -3 ''0 is at the right, not the left
If cbEntireNumber > iPos - 2 Then
''Convert hundreds
If cbEntireNumber > iPos Then
nHundreds = Val(Mid$(strEntireNumber, cbEntireNumber - iPos, 1))
If nHundreds > 0 Then
strOut = strOut & " " & Application.Choose(nHundreds, "One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight", "Nine") & " Hundred"
End If
End If
''Convert tens and ones
If cbEntireNumber > iPos - 1 Then
nTens = Val(Mid$(strEntireNumber, cbEntireNumber - iPos + 1, 1))
Else
nTens = 0
End If
If cbEntireNumber > iPos - 2 Then
nOnes = Val(Mid$(strEntireNumber, cbEntireNumber - iPos + 2, 1))
Else
nOnes = 0
End If
nTensOnes = nTens * 10 + nOnes
If nTensOnes > 9 And nTensOnes < 20 Then
strOut = strOut & " " & Application.Choose(nTensOnes, , , , , , , , , , "Ten", "Eleven", "Twelve", "Thirteen", "Fourteen", "Fifteen", "Sixteen", "Seventeen", "Eighteen", "Nineteen")
Else
If nTens >= 2 Then
strOut = strOut & " " & Application.Choose(nTens, , "Twenty", "Thirty", "Forty", "Fifty", "Sixty", "Seventy", "Eighty", "Ninety")
End If
If nOnes > 0 Then
If nTens >= 2 Then
strOut = strOut & "-"
Else
strOut = strOut & " "
End If
strOut = strOut & Application.Choose(nOnes, "One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight", "Nine")
End If
End If
''Add units if anything was converted for this block
If strOut <> strLast Then
strOut = strOut & " " & astrUnits(iPos)
strLast = strOut
End If
If strOut = "" Then strOut = "Zero"
End If
Next iPos
strOut = Trim(strOut) & " and " & Mid(strEntireNumber, cbEntireNumber - 1, 2) & "/100"
''Add units?
If IsMissing(units) Then strOut = strOut & " Dollars" Else strOut = strOut & " " & units
DOLLARTEXT = Trim(strOut)
End Function

 

[levanduyet]

Phần II
HÃY CÙNG KHÁM PHÁ CÁC HÀM CỦA POP
Function EXCELDIR() As String
' Trả về thư mục Excel được cài đặt
' Returns the directory in which Excel is installed
EXCELDIR = Application.Path
End Function
Function EXTRACTELEMENT(Txt, n, Separator) As String
' Hàm này cũng rất hay
' Returns the nth element of a text string, where the
' elements are separated by a specified separator character
' Split function is not available in versions prior to Excel 2000
EXTRACTELEMENT = Split(Application.Trim(Txt), Separator)(n - 1)
End Function
Function FILEEXISTS(file As String) As Boolean
' Trả về True nếu tập tin tồn tại
' Returns True if a specified file exists
On Error GoTo ErrorHandler
If file = "" Then
FILEEXISTS = False
Exit Function
End If
If Dir(file) = "" Then FILEEXISTS = False Else FILEEXISTS = True
Exit Function
ErrorHandler:
FILEEXISTS = False
End Function
Function FILENAME(Optional Cell)
' Trả về đường dẫn đầy đủ của workbook tham chiếu
' Returns the full path of the referenced workbook
If IsMissing(Cell) Then
FILENAME = Application.Caller.Parent.Parent.FullName
Else
FILENAME = Cell.Parent.Parent.FullName
End If
End Function
Function HINTERPOLATE(lookup_value, table_array, row_index_num)
' Tương tự như hàm HLookup, nhưng trả về một giá trị nội suy
' nếu giá trị chính xác không tìm thấy
' Performs linear interpolation
Dim Numcols As Long, i As Long
Dim range1 As Range, range2 As Range
Numcols = table_array.Columns.Count
Set range1 = table_array.Rows(1)
Set range2 = table_array.Rows(row_index_num)
' check for case if val = last value in range1
If lookup_value = range1.Cells(Numcols) Then
HINTERPOLATE = range2.Cells(Numcols)
Exit Function
End If
' Return an error if lookup_value is not within range1
If lookup_value > range1.Cells(Numcols) Or lookup_value < range1.Cells(1) Then
HINTERPOLATE = Evaluate("NA()")
Exit Function
End If
' Do linear interpolation
For i = 1 To Numcols - 1
If lookup_value >= range1.Cells(i) And lookup_value <= range1.Cells(i + 1) Then
HINTERPOLATE = (range2.Cells(i + 1) + (range2.Cells(i) - range2.Cells(i + 1)) * (lookup_value - range1.Cells(i + 1)) / (range1.Cells(i) - range1.Cells(i + 1)))
Exit Function
End If
Next i
End Function
Function INSERTSTRING(instring As String, origstring As String, pos As Long) As String
' Thêm vào một chuổi mới
' Inserts a new string (Instring) into OrigString at position Pos
Dim StLen As Long, i As Long
StLen = Len(origstring)
If pos <= 0 Then
INSERTSTRING = origstring
Exit Function
End If
If pos > StLen Then
INSERTSTRING = origstring & instring
Exit Function
End If
INSERTSTRING = Left(origstring, pos - 1) & instring & Right(origstring, StLen - pos + 1)
End Function
Function ISLIKE(text As String, pattern As String) As Boolean
' Trả về True nếu đối số thứ nhất giống thứ hai
' Returns true if the first argument is like the second
If text Like pattern Then ISLIKE = True Else ISLIKE = False
End Function
Function LASTINCOLUMN(ColRef As Range)
' Trả về cell cuối không có giá trị trong cột
' Returns the last non-empty cell in a column
Dim WorkRange As Range
Dim i As Integer, CellCount As Integer
Application.Volatile
Set WorkRange = ColRef.Columns(1).EntireColumn
Set WorkRange = Intersect(WorkRange.Parent.UsedRange, WorkRange)
If WorkRange Is Nothing Then
LASTINCOLUMN = ""
Exit Function
End If
CellCount = WorkRange.Count
For i = CellCount To 1 Step -1
If Not IsEmpty(WorkRange(i)) Then
LASTINCOLUMN = WorkRange(i).Value
Exit Function
End If
Next i
End Function
Function LASTINROW(RowRef As Range) As Variant
' Trả về cell cuối cùng không có giá trị trong một hàng
' Returns the last non-empty cell in a row
Dim WorkRange As Range
Dim i As Integer, CellCount As Integer
Application.Volatile
Set WorkRange = RowRef.Rows(1).EntireRow
Set WorkRange = Intersect(WorkRange.Parent.UsedRange, WorkRange)
If WorkRange Is Nothing Then
LASTINROW = ""
Exit Function
End If
CellCount = WorkRange.Count
For i = CellCount To 1 Step -1
If Not IsEmpty(WorkRange(i)) Then
LASTINROW = WorkRange(i).Value
Exit Function
End If
Next i
End Function
Function MAXALLSHEETS(Optional Cell As Range) As Variant
' Trả về giá trị lớn nhất trong các sheets
' Returns the maximum value across sheets
Dim RngArray() As Range, i As Long
Dim WkSht As Worksheet, WkBook As Workbook
Dim ArgIsMissing As Boolean
Application.Volatile
i = -1
If Cell Is Nothing Then
Set Cell = Application.Caller
ArgIsMissing = True
End If
Set WkBook = Cell.Parent.Parent
For Each WkSht In WkBook.Worksheets
If Not (ArgIsMissing And (WkSht.Name = Cell.Parent.Name)) Then
If Not IsEmpty(WkSht.Range(Cell.Address)) Then
i = i + 1
ReDim Preserve RngArray(0 To i)
Set RngArray(i) = WkSht.Range(Cell.Address)
End If
End If
Next WkSht
If i = -1 Then MAXALLSHEETS = 0 Else MAXALLSHEETS = Application.Max(RngArray)
End Function

 

[levanduyet]

Phần III
HÃY CÙNG KHÁM PHÁ CÁC HÀM CỦA POP
Function MINALLSHEETS(Optional Cell As Range) As Variant
' Trả về giá trị nhỏ nhất trong các sheets
' Returns the minimum value across sheets
Dim RngArray() As Range, i As Long
Dim WkSht As Worksheet, WkBook As Workbook
Dim ArgIsMissing As Boolean
Application.Volatile
i = -1
If Cell Is Nothing Then
Set Cell = Application.Caller
ArgIsMissing = True
End If
Set WkBook = Cell.Parent.Parent
For Each WkSht In WkBook.Worksheets
If Not (ArgIsMissing And (WkSht.Name = Cell.Parent.Name)) Then
If Not IsEmpty(WkSht.Range(Cell.Address)) Then
i = i + 1
ReDim Preserve RngArray(0 To i)
Set RngArray(i) = WkSht.Range(Cell.Address)
End If
End If
Next WkSht
If i = -1 Then MINALLSHEETS = 0 Else MINALLSHEETS = Application.Min(RngArray)
End Function
Function MONTHWEEK(serial_number As Date) As Long
' Trả về tuần thứ mấy ứng với giá trị ngày đưa vào
' Returns the week of the month for a date
Dim FirstDay As Long
' Check for valid date argument
If Not IsDate(serial_number) Then
MONTHWEEK = Evaluate("[HASHTAG]#VALUE[/HASHTAG]")
Exit Function
End If
' Get first day of the month
FirstDay = Weekday(DateSerial(Year(serial_number), Month(serial_number), 1))
' Calculate the week number
MONTHWEEK = Application.RoundUp((FirstDay + Day(serial_number) - 1) / 7, 0)
End Function
Function NUMBERFORMAT(Cell) As String
' Trả về chuỗi đại diện cho number format của cell
' Returns a string that represents the cell''s number format
NUMBERFORMAT = Cell(1).NumberFormatLocal
End Function
Function PARSENAME(nametext As String, name_seq As Long) As String
' Hàm cũng rất hay nhằm tách tên, tuổi và họ
Dim NameArray As Variant, RemoveArray As Variant, NewNameArray() As String
Dim n As String
Dim i As Long, j As Long
Dim Cnt As Long
' Get rid of excess spaces and commas
n = Application.Trim(nametext)
n = Replace(n, ",", "")
NameArray = Split(n, " ")
RemoveArray = Array("MR", "MRS", "MS", "DR", "JR", "II", "III", "SR", "MR.", "MRS.", "MS.", "DR.", "JR.", "SR.")
' Remove titles
For i = 0 To UBound(NameArray)
For j = 0 To UBound(RemoveArray)
If UCase(NameArray(i)) = RemoveArray(j) Then NameArray(i) = ""
Next j
Next i
' Create new array, sans titles
Cnt = 0
For i = 0 To UBound(NameArray)
If NameArray(i) <> "" Then
Cnt = Cnt + 1
ReDim Preserve NewNameArray(1 To Cnt)
NewNameArray(Cnt) = NameArray(i)
End If
Next i
Select Case UBound(NewNameArray)
Case 1
Select Case name_seq
Case 1: PARSENAME = NewNameArray(1)
Case 2: PARSENAME = ""
Case 3: PARSENAME = ""
End Select
Case 2
Select Case name_seq
Case 1: PARSENAME = NewNameArray(1)
Case 2: PARSENAME = ""
Case 3: PARSENAME = NewNameArray(2)
End Select
Case 3
Select Case name_seq
Case 1: PARSENAME = NewNameArray(1)
Case 2: PARSENAME = NewNameArray(2)
Case 3: PARSENAME = NewNameArray(3)
End Select
End Select
End Function
Function REMOVESPACES(text)
' Xóa hết tất cả các khỏang trống của một chuỗi
' Removes all spaces from its single-cell argument
Dim i As Long, k As String, text2 As Variant
REMOVESPACES = VBA.Replace(text, " ", "")
End Function
Function SCRAMBLE(text, Optional recalc)
' Đảo ngược thứ tự các ký tự trong một chuỗi
' Scrambles its single-cell argument
' If second argument is 1, then recalc it each time sheet is calculated
Dim Num As Long, i As Long, rpos As Long
Dim Temp As String, text2 As String
If IsMissing(recalc) Then recalc = 0
If recalc Then Application.Volatile
If IsArray(text) Then text2 = text(1) Else text2 = text
Num = Len(text2)
For i = 1 To Num
Temp = Mid(text2, i, 1)
rpos = Int((Num - 1 + 1) * Rnd + 1)
Mid(text2, i, 1) = Mid(text2, rpos, 1)
Mid(text2, rpos, 1) = Temp
Next i
SCRAMBLE = text2
End Function
Function SELECTONE(ParamArray number()) As Variant
' Lấy giá trị bất kỳ trong list
' Selects a value at random from arg list
Dim Elements() As Variant, ElementCount As Long
Dim i As Long
Dim Cell As Range
For i = 0 To UBound(number)
If Not IsError(number(i)) Then
If TypeName(number(i)) = "Range" Then
Set number(i) = Intersect(number(i).Parent.UsedRange, number(i))
For Each Cell In number(i)
ElementCount = ElementCount + 1
ReDim Preserve Elements(0 To ElementCount)
Elements(ElementCount) = Cell.Value
Next Cell
Else
ElementCount = ElementCount + 1
ReDim Preserve Elements(0 To ElementCount)
Elements(ElementCount) = number(i)
End If
End If
Next i
SELECTONE = Elements(Int((ElementCount - 1 + 1) * Rnd + 1))
End Function
Function SHEETCOUNT(Optional wksonly)
' Đếm các sheets
Application.Volatile
If IsMissing(wksonly) Then wksonly = True
If wksonly Then
SHEETCOUNT = Application.Caller.Parent.Parent.Worksheets.Count
Else
SHEETCOUNT = Application.Caller.Parent.Parent.Sheets.Count
End If
End Function
Function SHEETNAME(Optional sheetnum)
' Trả về tên của worksheet
' Returns the name of the worksheet
Dim s As Range
Set s = Application.Caller
If IsMissing(sheetnum) Then
SHEETNAME = s.Parent.Name
Else
SHEETNAME = s.Parent.Parent.Sheets(sheetnum).Name
End If
End Function
Function SHEETOFFSET(Offset As Long, Optional Cell As Range)
' Trả về giá trị của ô tương ứng đối với sheet trước hoặc sau
' Returns cell contents at Ref, in sheet offset
Dim WksIndex As Long, WksNum As Long
Dim wks As Worksheet
Application.Volatile
If Cell Is Nothing Then Set Cell = Application.Caller
WksNum = 1
For Each wks In Application.Caller.Parent.Parent.Worksheets
If Application.Caller.Parent.Name = wks.Name Then
SHEETOFFSET = Worksheets(WksNum + Offset).Range(Cell(1).Address)
Exit Function
Else
WksNum = WksNum + 1
End If
Next wks
End Function

 

[levanduyet]

Phần IV
HÃY CÙNG KHÁM PHÁ CÁC HÀM CỦA POP
Function STATICRAND()
' Trả về số random...
' Returns a random number that doesn''t change when worksheet recalcs
Application.Volatile (False)
STATICRAND = Rnd
End Function
Function SUMALLSHEETS(Optional Cell As Range) As Variant
' Cộng hết các giá trị của các cell cùng địa chỉ
' ở tất cả các sheet
' Sums a cell across all sheets
Dim i As Long
Dim WkSht As Worksheet, WkBook As Workbook
Dim ArgIsMissing As Boolean
Application.Volatile
i = -1
If Cell Is Nothing Then
Set Cell = Application.Caller
ArgIsMissing = True
End If
Set WkBook = Cell.Parent.Parent
For Each WkSht In WkBook.Worksheets
If Not (ArgIsMissing And (WkSht.Name = Cell.Parent.Name)) Then
If Not IsEmpty(WkSht.Range(Cell.Address)) Then
i = i + 1
SUMALLSHEETS = SUMALLSHEETS + WkSht.Range(Cell.Address).Value
End If
End If
Next WkSht
If i = -1 Then SUMALLSHEETS = 0
End Function
Function SUMVISIBLE(ParamArray number())
' Trả về tổng giá trị của các visible cells trong range
' Hàm này các bạn sẽ thường sử dụng
' Returns the sum of visible cells in a range
Dim Cell As Range, i As Long
Application.Volatile
SUMVISIBLE = 0
For i = 0 To UBound(number)
If Not IsError(number(i)) Then
If TypeName(number(i)) = "Range" Then
Set number(i) = Intersect(number(i).Parent.UsedRange, number(i))
For Each Cell In number(i)
If IsError(Cell) Then SUMVISIBLE = Cell: Exit Function
If Not Cell.EntireRow.Hidden And Not Cell.EntireColumn.Hidden Then SUMVISIBLE = SUMVISIBLE + Evaluate(Application.Sum(Cell))
Next Cell
Else
SUMVISIBLE = SUMVISIBLE + Evaluate(Application.Sum(number(i)))
End If
End If
Next i
End Function
Function TIMEXX(h As Double, m As Double, s As Double, x As Double, Optional fps As Double) As String
' Tạo chuổi ký tự, định dạng thời gian, cụ thể xin xem file help
' Create a TIMEXX string
Dim hh As Double, mm As Double, ss As Double, xx As Double
' Default to 100 if last argument is omitted
' Use 30 for SMPTE time codes
If fps = 0 Then fps = 100
' Return an error if an argument is negative
If m < 0 Or s < 0 Or x < 0 Or fps < 0 Then
TIMEXX = Evaluate("[HASHTAG]#VALUE[/HASHTAG]!")
Exit Function
End If
' Create working variables
hh = h: mm = m: ss = s: xx = x
' Check for overflow
If xx > fps - 1 Then
ss = ss + Int(xx / fps)
xx = (xx Mod fps)
End If
If ss > 59 Then
mm = mm + Int(ss / 60)
ss = (ss Mod 60)
End If
If mm > 59 Then
hh = hh + Int(mm / 60)
mm = (mm Mod 60)
End If
' Build the string
TIMEXX = Format(hh, "00:") & Format(mm, "00:") & Format(ss, "00:") & Format(xx, "00")
End Function
Function TIMEXX_ADD(n1 As String, n2 As String, Optional fps As Double) As String
' Tương tự hàm trên, nhưng cộng lại các giá trị của n1 và n2
' Adds two TIMEXX codes together
Dim h1 As Long, m1 As Long, s1 As Long, x1 As Long
Dim h2 As Long, m2 As Long, s2 As Long, x2 As Long
Dim h As Long, m As Long, s As Long, x As Long
Dim TotFrames As Double, LeftOverFrames As Double
Dim fph As Double, fpm As Double
Dim NegFlag As Boolean, NegFlag1 As Boolean, NegFlag2 As Boolean
Dim Offset1 As Long, Offset2 As Long
Dim Frames1 As Double, Frames2 As Double
' Treat blanks as zero
If n1 = "" Then n1 = "00:00:00:00"
If n2 = "" Then n2 = "00:00:00:00"
If fps = 0 Then fps = 100
If Len(n1) = 12 Then
Offset1 = 1
NegFlag1 = True
Else
Offset1 = 0
NegFlag1 = False
End If
If Len(n2) = 12 Then
Offset2 = 1
NegFlag2 = True
Else
Offset2 = 0
NegFlag2 = False
End If
h1 = CInt(Mid(n1, 1 + Offset1, 2))
m1 = CInt(Mid(n1, 4 + Offset1, 2))
s1 = CInt(Mid(n1, 7 + Offset1, 2))
x1 = CInt(Mid(n1, 10 + Offset1, 2))
h2 = CInt(Mid(n2, 1 + Offset2, 2))
m2 = CInt(Mid(n2, 4 + Offset2, 2))
s2 = CInt(Mid(n2, 7 + Offset2, 2))
x2 = CInt(Mid(n2, 10 + Offset2, 2))
If m1 > 59 Or s1 > 59 Or x1 > fps - 1 Or m2 > 59 Or s2 > 59 Or x2 > fps - 1 Then
TIMEXX_ADD = Evaluate("[HASHTAG]#VALUE[/HASHTAG]!")
Exit Function
End If
fph = fps * 60 * 60
fpm = fps * 60
Frames1 = (h1 * fph) + (m1 * fpm) + (s1 * fps) + x1
Frames2 = (h2 * fph) + (m2 * fpm) + (s2 * fps) + x2
If Not NegFlag1 And Not NegFlag2 Then
TotFrames = Frames1 + Frames2
NegFlag = False
End If
If NegFlag1 And NegFlag2 Then
TotFrames = Frames1 + Frames2
NegFlag = True
TotFrames = Abs(TotFrames)
End If
If NegFlag1 And Not NegFlag2 Then
TotFrames = Frames2 - Frames1
If TotFrames < 0 Then NegFlag = True Else NegFlag = False
TotFrames = Abs(TotFrames)
End If
If Not NegFlag1 And NegFlag2 Then
TotFrames = Frames1 - Frames2
If TotFrames < 0 Then NegFlag = True Else NegFlag = False
TotFrames = Abs(TotFrames)
End If
h = Int(TotFrames / fph)
If TotFrames >= fpm Then LeftOverFrames = (TotFrames Mod fph) Else LeftOverFrames = TotFrames
m = Int(LeftOverFrames / fpm)
If LeftOverFrames >= fpm Then LeftOverFrames = LeftOverFrames Mod fpm
s = Int(LeftOverFrames / fps)
If LeftOverFrames >= fps Then LeftOverFrames = LeftOverFrames Mod fps
x = LeftOverFrames
If NegFlag Then
TIMEXX_ADD = "-" & Format(h, "00:") & Format(m, "00:") & Format(s, "00:") & Format(x, "00")
Else
TIMEXX_ADD = Format(h, "00:") & Format(m, "00:") & Format(s, "00:") & Format(x, "00")
End If
End Function
Function TIMEXX_SUBTRACT(n1 As String, n2 As String, Optional fps As Double) As String
' Subtracts an TIMEXX code (n2) from an TIMEXX code (n1)
Dim h1 As Long, m1 As Long, s1 As Long, x1 As Long
Dim h2 As Long, m2 As Long, s2 As Long, x2 As Long
Dim h As Long, m As Long, s As Long, x As Long
Dim TotFrames As Double
Dim LeftOverFrames As Double
Dim fph As Double, fpm As Double
Dim NegFlag As Boolean, NegFlag1 As Boolean, NegFlag2 As Boolean
Dim Offset1 As Long, Offset2 As Long
Dim Frames1 As Double, Frames2 As Double
If fps = 0 Then fps = 100
' Treat blanks as zero
If n1 = "" Then n1 = "00:00:00:00"
If n2 = "" Then n2 = "00:00:00:00"
If Len(n1) = 12 Then
Offset1 = 1
NegFlag1 = True
Else
Offset1 = 0
NegFlag1 = False
End If
If Len(n2) = 12 Then
Offset2 = 1
NegFlag2 = True
Else
Offset2 = 0
NegFlag2 = False
End If
h1 = CInt(Mid(n1, 1 + Offset1, 2))
m1 = CInt(Mid(n1, 4 + Offset1, 2))
s1 = CInt(Mid(n1, 7 + Offset1, 2))
x1 = CInt(Mid(n1, 10 + Offset1, 2))
h2 = CInt(Mid(n2, 1 + Offset2, 2))
m2 = CInt(Mid(n2, 4 + Offset2, 2))
s2 = CInt(Mid(n2, 7 + Offset2, 2))
x2 = CInt(Mid(n2, 10 + Offset2, 2))
If m1 > 59 Or s1 > 59 Or x1 > fps - 1 Or m2 > 59 Or s2 > 59 Or x2 > fps - 1 Then
TIMEXX_SUBTRACT = Evaluate("[HASHTAG]#VALUE[/HASHTAG]!")
Exit Function
End If
fph = fps * 60 * 60
fpm = fps * 60
Frames1 = (h1 * fph) + (m1 * fpm) + (s1 * fps) + x1
Frames2 = (h2 * fph) + (m2 * fpm) + (s2 * fps) + x2
TotFrames = Frames1 - Frames2
If TotFrames < 0 Then
NegFlag = True
TotFrames = Abs(TotFrames)
Else
NegFlag = False
End If
h = Int(TotFrames / fph)
If TotFrames >= fpm Then LeftOverFrames = (TotFrames Mod fph) Else LeftOverFrames = TotFrames
m = Int(LeftOverFrames / fpm)
If LeftOverFrames >= fpm Then LeftOverFrames = LeftOverFrames Mod fpm Else LeftOverFrames = LeftOverFrames
s = Int(LeftOverFrames / fps)
If LeftOverFrames >= fps Then LeftOverFrames = LeftOverFrames Mod fps Else LeftOverFrames = LeftOverFrames
x = LeftOverFrames
If NegFlag Then
TIMEXX_SUBTRACT = "-" & Format(h, "00:") & Format(m, "00:") & Format(s, "00:") & Format(x, "00")
Else
TIMEXX_SUBTRACT = Format(h, "00:") & Format(m, "00:") & Format(s, "00:") & Format(x, "00")
End If
End Function

 

[levanduyet]

Phần V
HÃY CÙNG KHÁM PHÁ CÁC HÀM CỦA POP
Function TIMEXX_SUM(n1, ParamArray n2()) As String
' Sums SMTPE codes
Dim Cell As Range, args As Long, i As Long
Dim h1 As Long, m1 As Long, s1 As Long, x1 As Long
Dim h2 As Long, m2 As Long, s2 As Long, x2 As Long
Dim h As Long, m As Long, s As Long, x As Long
Dim TotFrames As Double, LeftOverFrames As Double
Dim AllParams()
Dim Offset As Long
Dim NegFlag As Boolean
Dim fps As Double, fpm As Double, fph As Double
' Put all arguments into the AllParams array
If UBound(n2) = -1 Then
ReDim AllParams(0 To 0)
If TypeName(n1) = "Range" Then Set AllParams(0) = n1 Else AllParams(0) = n1
Else
ReDim AllParams(0 To UBound(n2) + 1)
For i = LBound(n2) To UBound(n2)
If TypeName(n2(i)) = "Range" Then Set AllParams(i + 1) = n2(i) Else AllParams(i + 1) = n2(i)
Next i
If TypeName(n1) = "Range" Then Set AllParams(0) = n1 Else AllParams(0) = n1
End If
fps = 100
fpm = 60 * fps
fph = 60 * 60 * fps
TotFrames = 0
On Error GoTo NoCanDo
' Process the arguments
For args = 0 To UBound(AllParams)
Select Case TypeName(AllParams(args))
Case "Range"
Set AllParams(args) = Intersect(AllParams(args).Parent.UsedRange, AllParams(args))
For Each Cell In AllParams(args)
' Treat blanks as zero
If Cell = "" Then
h1 = "00"
m1 = "00"
s1 = "00"
x1 = "00"
Else
h1 = CInt(Split(Application.Trim(Cell), ":")(0))
m1 = CInt(Split(Application.Trim(Cell), ":")(1))
s1 = CInt(Split(Application.Trim(Cell), ":")(2))
x1 = CInt(Split(Application.Trim(Cell), ":")(3))
End If
TotFrames = TotFrames + (h1 * fph) + (m1 * fpm) + (s1 * fps) + x1
Next Cell
Case Else
If AllParams(args) = "" Then
h1 = "00"
m1 = "00"
s1 = "00"
x1 = "00"
Else
h1 = CInt(Split(Application.Trim(AllParams(args)), ":")(0))
m1 = CInt(Split(Application.Trim(AllParams(args)), ":")(1))
s1 = CInt(Split(Application.Trim(AllParams(args)), ":")(2))
x1 = CInt(Split(Application.Trim(AllParams(args)), ":")(3))
End If
TotFrames = TotFrames + (h1 * fph) + (m1 * fpm) + (s1 * fps) + x1
End Select
Next args
If TotFrames < 0 Then NegFlag = True Else NegFlag = False
TotFrames = Abs(TotFrames)
h = Int(TotFrames / fph)
If TotFrames >= fpm Then LeftOverFrames = (TotFrames Mod fph) Else LeftOverFrames = TotFrames
m = Int(LeftOverFrames / fpm)
If LeftOverFrames >= fpm Then LeftOverFrames = LeftOverFrames Mod fpm Else LeftOverFrames = LeftOverFrames
s = Int(LeftOverFrames / fps)
If LeftOverFrames >= fps Then LeftOverFrames = LeftOverFrames Mod fps Else LeftOverFrames = LeftOverFrames
x = LeftOverFrames
TIMEXX_SUM = Format(h, "00:") & Format(m, "00:") & Format(s, "00:") & Format(x, "00")
Exit Function
NoCanDo:
TIMEXX_SUM = Evaluate("[HASHTAG]#VALUE[/HASHTAG]!")
End Function
Function TOPAVERAGE(n, ParamArray values() As Variant) As Variant
' Xin xem file help, hàm có chức năng tương tự như tên gọi của nó
Dim Elements() As Variant, ElementCount As Long
Dim TopElements() As Variant
Dim i As Long
Dim Cell As Range
For i = 0 To UBound(values)
If Not IsError(values(i)) Then
If TypeName(values(i)) = "Range" Then
Set values(i) = Intersect(values(i).Parent.UsedRange, values(i))
For Each Cell In values(i)
ElementCount = ElementCount + 1
ReDim Preserve Elements(0 To ElementCount)
Elements(ElementCount) = Cell.Value
Next Cell
Else
ElementCount = ElementCount + 1
ReDim Preserve Elements(0 To ElementCount)
Elements(ElementCount) = values(i)
End If
End If
Next i
ReDim TopElements(1 To n)
For i = 1 To n
TopElements(i) = Application.Large(Elements, i)
Next i
TOPAVERAGE = Application.Average(TopElements)
End Function
Function UNIQUEITEMS(ArrayIn, Optional Count As Variant) As Variant
' Đếm các giá trị không trùng
' Accepts an array or range as input
' If Count = True or is missing, the function returns the number of unique elements
' If Count = False, the function returns a variant array of unique elements
Dim NoDupes As New Collection
Dim OutArray() As Variant
Dim Cell As Range, i As Long
' If 2nd argument is missing, assign default value
If IsMissing(Count) Then Count = True
Set ArrayIn = Intersect(ArrayIn, ArrayIn.Parent.UsedRange)
On Error Resume Next ''avoid error when adding duplicated item to collection
For Each Cell In ArrayIn
If Not IsEmpty(Cell) Then NoDupes.Add Cell.Value, CStr(Cell.Value)
Next Cell
If Count Then
UNIQUEITEMS = NoDupes.Count
Else
ReDim OutArray(1 To NoDupes.Count)
For i = 1 To NoDupes.Count
OutArray(i) = NoDupes(i)
Next i
UNIQUEITEMS = OutArray
End If
End Function

 

[levanduyet]

Phần VI
HÃY CÙNG KHÁM PHÁ CÁC HÀM POP
Function USER()
' Trả về tên người dùng hiện tại
' Returns the name of the current user
USER = Application.UserName
End Function
Function VINTERPOLATE(lookup_value, table_array, col_index_num)

' Tương tự như hàm VLookup, nhưng trả về một giá trị nội suy
' nếu giá trị chính xác không tìm thấy
' Performs linear interpolation
Dim NumRows As Long, i As Long
Dim range1 As Range, range2 As Range
NumRows = table_array.Rows.Count
Set range1 = table_array.Columns(1)
Set range2 = table_array.Columns(col_index_num)
' check for case if val = last value in range1
If lookup_value = range1.Cells(NumRows) Then
VINTERPOLATE = range2.Cells(NumRows)
Exit Function
End If
' Return an error if lookup_value is not within range1
If lookup_value > range1.Cells(NumRows) Or lookup_value < range1.Cells(1) Then
VINTERPOLATE = Evaluate("NA()")
Exit Function
End If
' Do linear interpolation
For i = 1 To NumRows - 1
If lookup_value >= range1.Cells(i) And lookup_value <= range1.Cells(i + 1) Then
VINTERPOLATE = (range2.Cells(i + 1) + (range2.Cells(i) - range2.Cells(i + 1)) * (lookup_value - range1.Cells(i + 1)) / (range1.Cells(i) - range1.Cells(i + 1)))
Exit Function
End If
Next i
End Function
Function WHICHDAY(weekdaynum, DOW, themonth, theyear) As Long
Dim i As Long, k As Long, BadData As Boolean
If weekdaynum >= 1 And weekdaynum <= 5 Then
If DOW >= 1 And DOW <= 7 Then
If themonth >= 1 And themonth <= 12 Then
For k = 1 To 7
If Weekday(DateSerial(theyear, themonth, k)) = DOW Then Exit For
Next k
If weekdaynum = 5 Then
WHICHDAY = DateSerial(theyear, themonth, k) + ((weekdaynum - 1) * 7)
i = DateSerial(theyear, themonth, k)
If Month(WHICHDAY) <> Month(i) Then WHICHDAY = WHICHDAY - 7
Else
WHICHDAY = DateSerial(theyear, themonth, k) + ((weekdaynum - 1) * 7)
End If
Else
WHICHDAY = CVErr(xlErrNA)
End If
Else
WHICHDAY = CVErr(xlErrNA)
End If
Else
WHICHDAY = CVErr(xlErrNA)
End If
End Function
Function XDATE(y, m, d, Optional fmt As String) As String
' Trả về ngày đặc biệt dựa vào chuỗi định dạng
If IsMissing(fmt) Then fmt = "Short Date"
XDATE = Format(DateSerial(y, m, d), fmt)
End Function
Function XDATEADD(xdate1, days, Optional fmt As String) As String
Dim i As Long, D1 As String
If IsMissing(fmt) Then fmt = "Short Date"
D1 = xdate1
For i = 1 To 7
D1 = Replace(D1, Format(i, "dddd"), "")
D1 = Replace(D1, Format(i, "ddd"), "")
Next i
XDATEADD = Format(DateValue(D1) + days, fmt)
End Function
Function XDATEDAY(xdate1)
Dim i As Long, D1 As String
D1 = xdate1
For i = 1 To 7
D1 = Replace(D1, Format(i, "dddd"), "")
D1 = Replace(D1, Format(i, "ddd"), "")
Next i
XDATEDAY = Day(DateValue(D1))
End Function
Function XDATEDIF(xdate1, xdate2) As Long
Dim i As Long, D1 As String, D2 As String
D1 = xdate1
For i = 1 To 7
D1 = Replace(D1, Format(i, "dddd"), "")
D1 = Replace(D1, Format(i, "ddd"), "")
Next i
D2 = xdate2
For i = 1 To 7
D2 = Replace(D2, Format(i, "dddd"), "")
D2 = Replace(D2, Format(i, "ddd"), "")
Next i
XDATEDIF = DateValue(D1) - DateValue(D2)
End Function
Function XDATEDOW(xdate1)
Dim i As Long, D1 As String
D1 = xdate1
For i = 1 To 7
D1 = Replace(D1, Format(i, "dddd"), "")
D1 = Replace(D1, Format(i, "ddd"), "")
Next i
XDATEDOW = Weekday(D1)
End Function
Function XDATEMONTH(xdate1)
Dim i As Long, D1 As String
D1 = xdate1
For i = 1 To 7
D1 = Replace(D1, Format(i, "dddd"), "")
D1 = Replace(D1, Format(i, "ddd"), "")
Next i
XDATEMONTH = Month(DateValue(D1))
End Function
Function XDATEYEAR(xdate1)
Dim i As Long, D1 As String
D1 = xdate1
For i = 1 To 7
D1 = Replace(D1, Format(i, "dddd"), "")
D1 = Replace(D1, Format(i, "ddd"), "")
Next i
XDATEYEAR = Year(DateValue(D1))
End Function
Function XDATEYEARDIF(xdate1, xdate2) As Long
Dim YearDiff As Long
Dim i As Long, D1 As String, D2 As String
D1 = xdate1
For i = 1 To 7
D1 = Replace(D1, Format(i, "dddd"), "")
D1 = Replace(D1, Format(i, "ddd"), "")
Next i
D2 = xdate2
For i = 1 To 7
D2 = Replace(D2, Format(i, "dddd"), "")
D2 = Replace(D2, Format(i, "ddd"), "")
Next i
YearDiff = Year(D2) - Year(D1)
If DateSerial(Year(D1), Month(D2), Day(D2)) < CDate(D1) Then YearDiff = YearDiff - 1
XDATEYEARDIF = YearDiff
End Function


Xin các bạn download về theo thread này và đọc file hướng dẫn.
http://www.webketoan.com/forum/showthread.php?t=5689
Chúc các bạn thành công.

Lê Văn Duyệt.
levanduyet@yahoo.com