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

Thảo luận trong 'Ứng dụng Excel' bắt đầu bởi levanduyet, 6 Tháng một 2005.

3,091 lượt xem

  1. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    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
    '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
     
    Last edited: 8 Tháng một 2005
    #1
  2. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    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
     
    #2
  3. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    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
     
    #3
  4. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    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
     
    #4
  5. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    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
     
    #5
  6. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    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
     
    #6

Chia sẻ trang này