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

[Pansy_flower]

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(******_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(******_number)
  y = Year(******_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
  'Copyright
  
  C)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

(Trích bài của anh Lê Văn Duyệt)
​

 

[Pansy_flower]

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

(Trích bài của anh Lê Văn Duyệt)​

 

[Pansy_flower]

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(******_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(******_number) Then
  MONTHWEEK = Evaluate("#VALUE")
  Exit Function
  End If
  ' Get first day of the month
  FirstDay = Weekday(DateSerial(Year(******_number), Month(******_number), 1))
  ' Calculate the week number
  MONTHWEEK = Application.RoundUp((FirstDay + Day(******_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

(Trích bài của anh Lê Văn Duyệt)
​

 

[Pansy_flower]

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("#VALUE!")
  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("#VALUE!")
  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("#VALUE!")
  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

(Trích bài viết của anh Lê Văn Duyệt)​

​

 

[Pansy_flower]

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("#VALUE!")
  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

(Trích bài của anh Lê Văn Duyệt)​

 

[Pansy_flower]

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.giaiphapexcel.com/forum/showthread.php?t=62

Chúc các bạn thành công.


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

 

[Mr Okebab]

Hôm nay mới được đọc cái này. Hay phết. Cảm ơn rất nhiều.

 

[Trần Văn Bình]

Cảm ơn anh nhiều
Thân

 

[anhtuan1066]

Cái hình này ***** là ký tự gì thế nhỉ? Dò trên diển đàn thấy nó là 5 ngôi sao ***** nhưng tại sao gõ 5 ngôi sao vào YM thì nó chẳng ra hình nhỉ... Down bài viết về rồi mà bối rối quá, ko biết hình ấy tương đương với ký tự gì? SG giúp giùm nha!
Mến
ANH TUẤN

 

[OverAC]

Cái hình này ***** là ký tự gì thế nhỉ? Dò trên diển đàn thấy nó là 5 ngôi sao ***** nhưng tại sao gõ 5 ngôi sao vào YM thì nó chẳng ra hình nhỉ... Down bài viết về rồi mà bối rối quá, ko biết hình ấy tương đương với ký tự gì? SG giúp giùm nha!
Mến
ANH TUẤN

Mấy cái này với bên YM hoàn toàn khác nhau anh àh.
Em đã điều chỉnh ***** lại để trong hình kia hiện ra được. Nhưng nếu để ***** thì em cũng không hiểu bài ở trên ****** tượng trưng cho cái gì.

 

[anhtuan1066]

Uh, tôi cũng chỉnh rồi... và cũng đang ko hiểu chổ này... Bình cao thủ mà còn ko biết thì làm sao tôi biết nỗi nhỉ ??? Hi... hi... Chắc phải Save nó thành xla rồi thử xem sao

 

[OverAC]

Anh Tuấn ơi,
Dù ****** đó nó có là gì đi nữa thì em nghĩ nó cũng chỉ là một phần của cái tên. nếu anh muốn anh có thể thay thế nó thành một cái tên khác. Không vấn đề gì cả, chỉ cần thay sao cho nhất quán.