Useful functions - Các hàm hữu ích

Liên hệ QC

levanduyet

Hãy để gió cuốn đi.
Thành viên danh dự
Tham gia
30/5/06
Bài viết
1,798
Được thích
4,699
Giới tính
Nam
1) Hàm xác định:
  • Hàng cuối (last row).
  • Cột cuối (last column).
  • Ô cuối (last cell).
Nguồn tại đây.

Mã:
Function RDB_Last(choice As Integer, rng As Range)
' Giá trị choice đưa vào
' 1 = tìm hàng cuối
' 2 = tìm cột cuối
' 3 = tìm ô cuối
    Dim lrw As Long
    Dim lcol As Integer

    Select Case choice

    Case 1:
        On Error Resume Next
        RDB_Last = rng.Find(What:="*", _
                            after:=rng.cells(1), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
        On Error GoTo 0

    Case 2:
        On Error Resume Next
        RDB_Last = rng.Find(What:="*", _
                            after:=rng.cells(1), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
        On Error GoTo 0

    Case 3:
        On Error Resume Next
        lrw = rng.Find(What:="*", _
                       after:=rng.cells(1), _
                       Lookat:=xlPart, _
                       LookIn:=xlFormulas, _
                       SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious, _
                       MatchCase:=False).Row
        On Error GoTo 0

        On Error Resume Next
        lcol = rng.Find(What:="*", _
                        after:=rng.cells(1), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
        On Error GoTo 0

        On Error Resume Next
        RDB_Last = rng.Parent.cells(lrw, lcol).Address(False, False)
        If Err.Number > 0 Then
            RDB_Last = rng.cells(1).Address(False, False)
            Err.Clear
        End If
        On Error GoTo 0

    End Select
End Function

Tìm hàng cuối của một cột:
Thông thường để tìm hàng cuối cùng của một cột (manual), chúng ta sẽ thực hiện các bước sau:
  • Nhấn tổ hợp phím Ctrl + End để di chuyển đến ô có dữ liệu cuối cùng của một worksheet.
  • Di chuyển con trỏ chuột đến cột mà chúng ta muốn tìm hàng cuối cùng.
  • Sau đó nhấn tổ hợp phím Ctrl + Phím mủi tên lên.

Thao tác này tương đương với đoạn mã sau:

Mã:
Sub LastRowInOneColumn()
'Tìm hàng có dữ liệu cuối cùng của một cột. Ở đây ta tìm hàng cuối cùng của cột A
'Vậy khi muốn tìm ở cột nào thì bạn thay thế tên cột đó
    Dim LastRow As Long
    With ActiveSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'Tương đương với việc bấm tổ hợp Ctrl + Phím mủi tên đi lên
    End With
    MsgBox LastRow
End Sub
[/GPECODE]

Tìm cột cuối cùng của một hàng:
Cách làm cũng tương tự trên.
[GPECODE=vb]
Sub LastColumnInOneRow()
'Tìm cột cuối cùng của một hàng: giả sử ở đây chúng ta tìm ở hàng số 1
    Dim LastCol As Integer
    With ActiveSheet
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    End With
    MsgBox LastCol
End Sub

Chú ý:
Với cách này nếu các bạn merged các ô (merged cells) thì kết quả có khi sẽ bị sai.

Hàm GetLastCell của Chip Pearson:

Mã:
Public Function GetLastCell(InRange As Range, SearchOrder As XlSearchOrder, _
                        Optional ProhibitEmptyFormula As Boolean = False) As Range
'''''
' GetLastCell
' By Chip Pearson, chip@cpearson.com, www.cpearson.com
'
' This returns the last used cell in a worksheet or range. If InRange
' is a single cell, the last cell of the entire worksheet if found. If
' InRange contains two or more cells, the last cell in that range is
' returned.
' If SearchOrder is xlByRows (= 1), the last cell is the last
' (right-most) non-blank cell on the last row of data in the
' worksheet's UsedRange. If SearchOrder is xlByColumns
' (= 2), the last cell is the last (bottom-most) non-blank cell in the
' last (right-most) column of the worksheet's UsedRange. If SearchOrder
' is xlByColumns + xlByRows (= 3), the last cell is the intersection of
' the last row and the last column. Note that this cell may not contain
' any value.
' If SearchOrder is anything other than xlByRows, xlByColumns, or
' xlByRows+xlByColumns, an error 5 is raised.
'
' ProhibitEmptyFormula indicates how to handle the case in which the
' last cell is a formula that evaluates to an empty string. If this setting
' is omitted for False, the last cell is allowed to be a formula that
' evaluates to an empty string. If this setting is True, the last cell
' must be either a static value or a formula that evaluates to a non-empty
' string. The default is False, allowing the last cell to be a formula
' that evaluates to an empty string.
'''''''
' Example:
'       a   b   c
'               d   e
'       f   g
'
' If SearchOrder is xlByRows, the last cell is 'g'. If SearchOrder is
' xlByColumns, the last cell is 'e'. If SearchOrder is xlByRows+xlByColumns,
' the last cell is the intersection of the row containing 'g' and the column
' containing 'e'. This cell has no value in this example.
'
'''''
Dim WS As Worksheet
Dim R As Range
Dim LastCell As Range
Dim LastR As Range
Dim LastC As Range
Dim SearchRange As Range
Dim LookIn As XlFindLookIn
Dim RR As Range

Set WS = InRange.Worksheet

If ProhibitEmptyFormula = False Then
    LookIn = xlFormulas
Else
    LookIn = xlValues
End If

Select Case SearchOrder
    Case XlSearchOrder.xlByColumns, XlSearchOrder.xlByRows, _
            XlSearchOrder.xlByColumns + XlSearchOrder.xlByRows
        ' OK
    Case Else
        Err.Raise 5
        Exit Function
End Select

With WS
    If InRange.Cells.Count = 1 Then
        Set RR = .UsedRange
    Else
       Set RR = InRange
    End If
    Set R = RR(RR.Cells.Count)
   
    If SearchOrder = xlByColumns Then
        Set LastCell = RR.Find(what:="*", after:=R, LookIn:=LookIn, _
                LookAt:=xlPart, SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, MatchCase:=False)
    ElseIf SearchOrder = xlByRows Then
        Set LastCell = RR.Find(what:="*", after:=R, LookIn:=LookIn, _
                LookAt:=xlPart, SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, MatchCase:=False)
    ElseIf SearchOrder = xlByColumns + xlByRows Then
        Set LastC = RR.Find(what:="*", after:=R, LookIn:=LookIn, _
                LookAt:=xlPart, SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, MatchCase:=False)
        Set LastR = RR.Find(what:="*", after:=R, LookIn:=LookIn, _
                LookAt:=xlPart, SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, MatchCase:=False)
        Set LastCell = Application.Intersect(LastR.EntireRow, LastC.EntireColumn)
    Else
        Err.Raise 5
        Exit Function
    End If
End With

Set GetLastCell = LastCell

End Function
Nguồn tại đây.
Các bạn tham khảo thêm tại:

 
Lần chỉnh sửa cuối:
Khi lập trình VBA, một số thao tác các bạn thường xuyên sử dụng như:
  • Kiểm tra tập tin có tồn tại hay không?
  • Kiểm tra đường dẫn có tồn tại hay không?
Nguồn tại đây.
Tôi xin giới thiệu các bạn 6 hàm sau:
  • 2) FileExists: kiểm tra sự tồn tại của tập tin - Trả về TRUE nếu tập tin tồn tại.
  • 3) FileNameOnly: lấy tên tập tin từ đường dẫn.
  • 4) PathExists : kiểm tra đường dẫn có tồn tại hay không? - Trả về TRUE nếu đường dẫn tồn tại.
  • 5) RangeNameExists : kiểm tra tên của một vùng (Range) có tồn tại hay không? - Trả về TRUE nếu tên vùng tồn tại.
  • 6) SheetExists : kiểm tra sheet có tồn tại hay không? - Trả về TRUE nếu sheet tồn tại.
  • 7) WorkBookIsOpen : kiểm tra xem tập tin có đang mở hay không? - Trả về TRUE nếu tập tin đang mở.

Mã:
Private Function FileExists(fname) As Boolean
'   Returns TRUE if the file exists
    Dim x As String
    x = Dir(fname)
    If x <> "" Then FileExists = True _
        Else FileExists = False
End Function


Private Function FileNameOnly(pname) As String
'   Returns the filename from a path/filename string
    Dim i As Integer, length As Integer, temp As String
    length = Len(pname)
    temp = ""
    For i = length To 1 Step -1
        If Mid(pname, i, 1) = Application.PathSeparator Then
            FileNameOnly = temp
            Exit Function
        End If
        temp = Mid(pname, i, 1) & temp
    Next i
    FileNameOnly = pname
End Function


Private Function PathExists(pname) As Boolean
'   Returns TRUE if the path exists
    Dim x As String
    On Error Resume Next
    x = GetAttr(pname) And 0
    If Err = 0 Then PathExists = True _
      Else PathExists = False
End Function


Private Function RangeNameExists(nname) As Boolean
'   Returns TRUE if the range name exists
    Dim n As Name
    RangeNameExists = False
    For Each n In ActiveWorkbook.Names
        If UCase(n.Name) = UCase(nname) Then
            RangeNameExists = True
            Exit Function
        End If
    Next n
End Function


Private Function SheetExists(sname) As Boolean
'   Returns TRUE if sheet exists in the active workbook
    Dim x As Object
    On Error Resume Next
    Set x = ActiveWorkbook.Sheets(sname)
    If Err = 0 Then SheetExists = True _
        Else SheetExists = False
End Function


Private Function WorkbookIsOpen(wbname) As Boolean
'   Returns TRUE if the workbook is open
    Dim x As Workbook
    On Error Resume Next
    Set x = Workbooks(wbname)
    If Err = 0 Then WorkbookIsOpen = True _
        Else WorkbookIsOpen = False
End Function

Cách khác để kiểm tra sự tồn tại của một tập tin:
Ngoài ra chúng ta cũng có thể dùng FileSystemObject để kiểm tra sự tồn tại của một tập tin. Hàm FileExists có thể viết lại như sau:

Mã:
Function FileExists(ByVal fname As String) As Boolean
    Set fs = CreateObject("Scripting.FileSystemObject")
    FileExists = fs.FileExists(fname)
End Function
Một cách khác:
Mã:
Function bFileExists(rsFullPath As String) As Boolean
  bFileExists = CBool(Len(Dir$(rsFullPath)) > 0)
End Function
Cách tương tự nhưng bạn có thể kiểm tra sự tồn tại của tập tin/thư mục. Nguồn từ đây.
Mã:
Public Function FileFolderExists(strFullPath As String) As Boolean
'Tác giả/Author       : Ken Puls (www.excelguru.ca)
'Mục đích/Macro Purpose: Kiểm tra sự tồn tại của một tập tin/thư mục - Check if a file or folder exists

    On Error GoTo EarlyExit
    If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
   
EarlyExit:
    On Error GoTo 0

End Function

Cách khác để kiểm tra sự workbook có đang mở hay không:
Mã:
Function bWorkbookIsOpen(rsWbkName As String) As Boolean
On Error Resume Next
  bWorkbookIsOpen = CBool(Len(Workbooks(rsWbkName).Name) > 0)
End Function
Một hàm cùng chức năng để các bạn tham khảo:
Nguồn tại đây.
Các bạn đưa đoạn mã sau vào một module.
Mã:
Option Explicit
Option Compare Text
' modIsFileOpen
' By Chip Pearson, www.cpearson.com , chip@cpearson.com
' www.cpearson.com/Excel/IsFileOpen.aspx
' This module contains the IsFileOpen procedure whict tests whether
' a file is open.
' Module chứa hàm IsFileOpen nhằm kiểm tra việc tập tin đang mở hoặc đang
' được sử dụng bởi một process khác

Public Function IsFileOpen(FileName As String, _
    Optional ResultOnBadFile As Variant) As Variant
'
' IsFileOpen
' This function determines whether a the file named by FileName is
' open by another process. The fuction returns True if the file is open
' or False if the file is not open. If the file named by FileName does
' not exist or if FileName is not a valid file name, the result returned
' if equal to the value of ResultOnBadFile if that parameter is provided.xd
' If ResultOnBadFile is not passed in, and FileName does not exist or
' is an invalid file name, the result is False.

Dim FileNum As Integer
Dim ErrNum As Integer
Dim V As Variant

On Error Resume Next

' If we were passed in an empty string,
' there is no file to test so return FALSE.

If Trim(FileName) = vbNullString Then
    If IsMissing(ResultOnBadFile) = True Then
        IsFileOpen = False
    Else
        IsFileOpen = ResultOnBadFile
    End If
    Exit Function
End If

' if the file doesn't exist, it isn't open
' so get out now
V = Dir(FileName, vbNormal)
If IsError(V) = True Then
    ' syntactically bad file name
    If IsMissing(ResultOnBadFile) = True Then
        IsFileOpen = False
    Else
        IsFileOpen = ResultOnBadFile
    End If
    Exit Function
ElseIf V = vbNullString Then
    ' file doesn't exist.
    If IsMissing(ResultOnBadFile) = True Then
        IsFileOpen = False
    Else
        IsFileOpen = ResultOnBadFile
    End If
    Exit Function
End If

FileNum = FreeFile()
' Attempt to open the file and lock it.
Err.Clear
Open FileName For Input Lock Read As #FileNum
ErrNum = Err.Number
' Close the file.

Close FileNum
On Error GoTo 0

' Check to see which error occurred.
Select Case ErrNum
    Case 0
        '
        ' No error occurred.
        ' File is NOT already open by another user.
        '
        IsFileOpen = False
    Case 70
        ' Error number for "Permission Denied."
        ' File is already opened by another user.
        IsFileOpen = True
    Case Else
        ' Another error occurred. Assume open.
        IsFileOpen = True
End Select

End Function

Chú ý: với cách ở trên thì hàm cũng kiểm tra luôn trong các process (Ví dụ: khi bạn vào Start>All Programs>Microsoft Office>Microsoft Excel, mở một tập tin. Sau đó bạn mở một tập tin khác cũng bằng cách này. Sau đó bạn nhấn tổ hợp Ctrl + Alt + Delete: bạn sẽ thấy hai process Excel.exe ) đang mở khác.
Cách tương tự, viết ngắn gọn lại, dễ hiểu hơn như sau:
Mã:
Function IsFileOpen(FileName As String)
    Dim iFilenum As Long
    Dim iErr As Long
    
    On Error Resume Next
    iFilenum = FreeFile()
    Open FileName For Input Lock Read As #iFilenum
    Close iFilenum
    iErr = Err
    On Error Goto 0
    
    Select Case iErr
    Case 0:    IsFileOpen = False
    Case 70:   IsFileOpen = True
    Case Else: Error iErr
    End Select
    
End Function

Sub test()
    If Not IsFileOpen("C:\MyTest\volker2.xls") Then
        Workbooks.Open "C:\MyTest\volker2.xls"
    End If
End Sub

Hoặc các bạn cũng có thể tham khảo tại đây: http://support.microsoft.com/?kbid=138621
Đoạn code tương ứng với link ở trên của Microsoft như sau:

Mã:
Sub TestFileOpened()

' Test to see if the file is open.
    If IsFileOpen("c:\Book2.xls") Then
        ' Display a message stating the file in use.
        MsgBox "File already in use!"
        '
        ' Add code here to handle case where file is open by another
        ' user.
        '
    Else
        ' Display a message stating the file is not in use.
        MsgBox "File not in use!"
        ' Open the file in Microsoft Excel.
        Workbooks.Open "c:\Book2.xls"
        '
        ' Add code here to handle case where file is NOT open by
        ' another user.
        '
    End If
End Sub

Function IsFileOpen(filename As String)
    Dim filenum As Integer, errnum As Integer

    On Error Resume Next                              'Tắt việc kiểm tra lỗi.
    filenum = FreeFile()                              ' Get a free file number.
    ' Thử mở tập tin vào khóa nó
    Open filename For Input Lock Read As #filenum
    Close filenum                                     ' Đóng tập tin
    errnum = Err                                      ' Lưu lại lỗi xãy ra
    On Error GoTo 0                                   ' Mở lại việc kiểm tra lỗi

    ' Kiểm tra xem lỗi gì xãy ra
    Select Case errnum

        ' Không có lỗi xãy ra
        ' Tập tin chưa mở bởi người dùng khác
    Case 0
        IsFileOpen = False

        ' Error number for "Permission Denied."
        ' Tập tin được mở bởi người dùng khác
    Case 70
        IsFileOpen = True

        ' Lỗi khác xãy ra
    Case Else
        Error errnum
    End Select
End Function


Cách khác để kiểm tra sự tồn tại của worksheet:
Mã:
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

Các bạn có thể tham khảo thêm tại http://www.rondebruin.nl/exist.htm.
 
Lần chỉnh sửa cuối:
8) Xác định một vùng có tồn tại trong một vùng khác hay không

Trong một số trường hợp các bạn muốn biết một vùng này có nằm trong một vùng kia hay không. Ví dụ: bạn cần biết ô hiện hành có nằm trong một vùng nào đó hay không chằng hạn.

Trong trường hợp này các bạn có thể dùng hàm sau:
Chú ý rằng, hàm kiểm tra để chắc chắn rằng hai vùng bạn đưa vào hàm này phải cùng trên một workbook và cùng trên một worksheet.

Bạn có thể dùng hàm này trong VBA hoặc worksheet.

Mã:
Function InRange(rng1, rng2) As Boolean
'   Returns True if rng1 is a subset of rng2
    InRange = False
    If rng1.Parent.Parent.Name = rng2.Parent.Parent.Name Then
        If rng1.Parent.Name = rng2.Parent.Name Then
            If Union(rng1, rng2).Address = rng2.Address Then
                InRange = True
            End If
        End If
    End If
End Function

Ví dụ:

Ví dụ sau cho người sử dụng chọn một vùng và sử dụng hàm InRange để kiểm tra. Nếu người dùng không chọn trong vùng A1:E20, thì hộp thoại yêu cầu sẽ lại hiện ra lại.
Mã:
Sub Test()
    Dim ValidRange As Range, UserRange As Range
    Dim SelectionOK As Boolean
  
    Set ValidRange = Range("A1:E20")
    SelectionOK = False
    On Error Resume Next

    Do Until SelectionOK = True
        Set UserRange = Application.InputBox(Prompt:="Select a range", Type:=8)
        If TypeName(UserRange) = "Empty" Then Exit Sub
        If InRange(UserRange, ValidRange) Then
            MsgBox "The range is valid."

            SelectionOK = True
        Else
            MsgBox "Select a range within " & ValidRange.Address
        End If
    Loop
End Sub

Nguồn từ đây.

Kiểm tra ô hiện hành (ActiveCell) có nằm trong một vùng hay không?

Mã:
Sub CellinRange()
    Dim rngArea As Range

    ' Vùng dữ liệu bạn muốn kiểm tra
    ' Bạn có thể thay đổi theo ý bạn
    Set rngArea = Range("A1:C5")   
   
' Dùng Intersect để kiểm tra
    If Application.Intersect(rngArea, ActiveCell) Is Nothing Then
       MsgBox ("Ô hiện tại không có trong vùng này.")
    Else
       MsgBox ("Ô hiện tại đang ở trong vùng này.")
    End If
End Sub


Nguồn tại đây, bài của SA_DQ.

Bài viết cụ thể về phương thức Intersect xin xem tại đây.
 

File đính kèm

  • Intersect.xls
    28.5 KB · Đọc: 852
Lần chỉnh sửa cuối:
9) Hàm chuyển đổi số thứ tự cột thành chữ - Column number to Column letter

Đôi khi trong lập trình VBA chúng ta muốn chuyển đổi cột từ số sang chữ, các bạn có thể sử dụng hàm sau:

Mã:
Function ColumnLetter(ColumnNumber As Integer) As String
    
    '
    'example usage:
    '
    'Dim temp As Integer
    'temp = Sheets(1).Range("B2").End(xlToRight).Column
    'MsgBox "The last column of this region is " & _
    '        ColumnLetter(temp)
    '
      
If ColumnNumber <= 0 Then
    'negative column number
    ColumnLetter = ""
  
ElseIf ColumnNumber > 16384 Then
    'column not supported (too big) in Excel 2007
    ColumnLetter = ""
  
ElseIf ColumnNumber > 702 Then
    ' triple letter columns
    ColumnLetter = _
    Chr((Int((ColumnNumber-1-26-676) / 676)) Mod 676 + 65) & _
    Chr((Int((ColumnNumber-1-26) / 26) Mod 26) + 65) & _
    Chr(((ColumnNumber-1) Mod 26) + 65)

ElseIf ColumnNumber > 26 Then
    ' double letter columns
    ColumnLetter = Chr(Int((ColumnNumber-1) / 26) + 64) & _
            Chr(((ColumnNumber-1) Mod 26) + 65)
Else
    ' single letter columns
    ColumnLetter = Chr(ColumnNumber + 64)

End If
  
End Function

Nguồn từ đây.

Còn đây nếu dùng công thức:

Mã:
Function CotDoiSangChu(n As Integer) As String
    Dim s As String
    s = Cells(1, n).Address
    CotDoiSangChu = Mid(s, 2, InStr(2, s, "$") - 2)
End Function

Nếu muốn dùng trong AutoIt thì dùng hàm sau:

Mã:
; ----------------------------------------------------------------------------------------------------
; Function Name:   _ExcelColumnLetter()
; Description:      Converts Microsoft Excel column number (1 - 16384) into column letter(s)
;                   [http://www.freevbcode.com/ShowCode.asp?ID=9264].
; Syntax:           _ExcelColumnLetter([$iColumn = 0])
; Parameter(s):     $iColumn - The column number to convert into column letter(s).
; Requirement(s):   None.
; Return Value(s):  Success - "A" to "XFD", @error = 0, @extended = 1, 2, 3.
;                   Failure - "", @error = 1, @extended = 0.
; ----------------------------------------------------------------------------------------------------
Func _ExcelColumnLetter($iColumn = 0)
    Switch $iColumn
        Case 1 To 26 ; Single letter columns (1 = "A" - 26 = "Z").
            Local $letter1 = Chr($iColumn + 64)
            Return SetError(0, 1, $letter1)
        Case 27 To 702 ; Double letter columns (27 = "AA" - 702 = "ZZ").
            Local $letter1 = Chr(Int(($iColumn - 1) / 26) + 64)
            Local $letter2 = Chr(Mod(($iColumn - 1), 26) + 65)
            Return SetError(0, 2, $letter1 & $letter2)
        Case 703 To 16384 ; Triple letter columns (703 = "AAA" - 16384 = "XFD" [18278 = "ZZZ"]).
            Local $letter1 = Chr(Mod(Int(($iColumn - 1 - 26 - 676) / 676), 676) + 65)
            Local $letter2 = Chr(Mod(Int(($iColumn - 1 - 26) / 26), 26) + 65)
            Local $letter3 = Chr(Mod(($iColumn - 1), 26) + 65)
            Return SetError(0, 3, $letter1 & $letter2 & $letter3)
    EndSwitch
    Return SetError(1, 0, "")
EndFunc

Nguồn tại đây.

Chúc các bạn cuối tuần vui vẻ.

Lê Văn Duyệt
 
Lần chỉnh sửa cuối:
10) Kiểm tra xem địa chỉ tham chiếu có đúng không?

Trong lập trình VBA, đôi khi chúng ta cần phải kiểm tra xem địa chỉ tham chiếu đến một vùng có đúng hay không trước khi thực hiện bước tiếp theo.

Xin giới thiệu các bạn hàm kiểm tra IsValidRef, của Tác giả Jan Karel Pieterse

Các bạn hãy đưa đoạn mã này vào một module, rồi thay đổi các giá trị tham chiếu trong ví dụ Test1 để kiểm tra.


Mã:
Option Explicit

Public Function IsValidRef(sRef As String) As Boolean
'-------------------------------------------------------------------------
' Procedure : IsValidRef Created by Jan Karel Pieterse
' Company   : JKP Application Development Services (c) 2005
' Author    : Jan Karel Pieterse
' Created   : 21-12-2005
' Purpose/Mục đích   : Checks of argument is a valid cell reference
'-------------------------------------------------------------------------
    Dim sTemp As String
    Dim oSh As Worksheet
    Dim oCell As Range
 
    IsValidRef = False
    On Error Resume Next
    sTemp = Left(sRef, InStr(sRef, "!") - 1)
    sTemp = Replace(sTemp, "=", "")
    If Not IsIn(ActiveWorkbook.Worksheets, sTemp) Then
        IsValidRef = False
        Exit Function
    End If
    Set oSh = ActiveWorkbook.Worksheets(sTemp)
    If oSh Is Nothing Then
        Set oSh = ActiveWorkbook.Worksheets(Replace(sTemp, "'", ""))
    End If
    sTemp = Right(sRef, Len(sRef) - InStr(sRef, "!"))
    Set oCell = oSh.Range(sTemp)
    If oCell Is Nothing Then
        IsValidRef = False
    Else
        IsValidRef = True
    End If
End Function
Function [COLOR="red"]IsIn[/COLOR](vCollection As Variant, ByVal sName As String) As Boolean
'-------------------------------------------------------------------------
' Procedure : funIsIn Created by Jan Karel Pieterse
' Company   : JKP Application Development Services (c) 2005
' Author    : Jan Karel Pieterse
' Created   : 28-12-2005
' Purpose/Mục đích   : [COLOR="blue"]Kiểm tra xem đối tượng có trong Collection hay không?[/COLOR]/ Determines if object is in collection
'-------------------------------------------------------------------------
    Dim oObj As Object
    On Error Resume Next
    Set oObj = vCollection(sName)
    If oObj Is Nothing Then
        IsIn = False
    Else
        IsIn = True
    End If
    If IsIn = False Then
        sName = Replace(sName, "'", "")
        Set oObj = vCollection(sName)
        If oObj Is Nothing Then
            IsIn = False
        Else
            IsIn = True
        End If
    End If
End Function


Sub Test1()
    Dim bTest As Boolean
    bTest = IsValidRef("Sheet1!A3")
    Debug.Print bTest
End Sub

Nguồn tại đây.
 

File đính kèm

  • CheckInvalidCellRef.xls
    36 KB · Đọc: 726
Lần chỉnh sửa cuối:
11. Hàm Tìm một từ trong một chuổi

Đôi khi chúng ta muốn tìm một từ trong một chuổi.
Ví dụ: tôi muốn tìm từ cho những trong chuổi xã hội lên án các cộng đồng mạng ủng hộ cho những việc không đúng
Các bạn có thể dùng hàm sau:
Mã:
Function IsWholeWord(ByVal SearchWhat As String, ByVal SearchFor As String, _
                     Optional IgnoreCase As Boolean = True) As Boolean
  If IgnoreCase Then SearchWhat = UCase(SearchWhat): SearchFor = UCase(SearchFor)
  IsWholeWord = " " & SearchWhat & " " Like "*[!A-Za-z0-9]" & SearchFor & "[!A-Za-z0-9]*"
End Function

Hoặc
Mã:
Function IsWholeWord(ByVal SearchWhat As String, ByVal SearchFor As String, _
                       Optional IgnoreCase As Boolean = True) As Boolean
  IsWholeWord = " " & Format(SearchWhat, Mid(">", 2 + IgnoreCase)) & " " Like "*[!A-Za-z0-9]" & _
                Format(SearchFor, Mid(">", 2 + IgnoreCase)) & "[!A-Za-z0-9]*"
End Function

Vậy ta có thể viết
Mã:
IsWholeWord("cho những","xã hội lên án các cộng đồng mạng ủng hộ cho những việc không đúng")
Hoặc nếu các bạn đặt từ "cho những" tại ô A1, còn "xã hội lên án các cộng đồng mạng ủng hộ cho những việc không đúng" tại ô A2, thì bạn có thể lập công thức như sau:
Mã:
=IsWholeWord(A2,A1,FALSE)

Tham khảo tại đây.

Lê Văn Duyệt
 
Lần chỉnh sửa cuối:
12. Thủ tục giúp mở sheet có mật khẩu

Mã:
SubPasswordBreaker()
' Tác giả: không biết; Nguồn từ www.experts-exchange.com

    Dim i As Integer, j As Integer, k As Integer
    Dim l As Integer, m As Integer, n As Integer
    Dim i1 As Integer, i2 As Integer, i3 As Integer
    Dim i4 As Integer, i5 As Integer, i6 As Integer
    On Error Resume Next
    For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
                For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
                            For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
                                        For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126


                                                    ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _
                                                                          Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
                                                                          Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
                                                    If ActiveSheet.ProtectContents = False Then
                                                        MsgBox "One usable password is " & Chr(i) & Chr(j) & _
                                                               Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
                                                               Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
                                                        ActiveWorkbook.Sheets(1).Select
                                                        Range("a1").FormulaR1C1 = Chr(i) & Chr(j) & _
                                                                                  Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
                                                                                  Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
                                                        Exit Sub
                                                    End If
                                                Next: Next: Next: Next: Next: Next
                        Next: Next: Next: Next: Next: Next


End Sub
 
Lần chỉnh sửa cuối:
13. Hàm đọc số thành chữ tiếng Anh:

Nguồn: http://support.microsoft.com/kb/213360

Mã:
Function SpellNumber(ByVal MyNumber)
    Dim Dollars, Cents, Temp
    Dim DecimalPlace, Count
    ReDim Place(9) As String
    Place(2) = " Thousand "
    Place(3) = " Million "
    Place(4) = " Billion "
    Place(5) = " Trillion "
    ' String representation of amount.
    MyNumber = Trim(Str(MyNumber))
    ' Position of decimal place 0 if none.
    DecimalPlace = InStr(MyNumber, ".")
    ' Convert cents and set MyNumber to dollar amount.
    If DecimalPlace > 0 Then
        Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & _
                  "00", 2))
        MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
    End If
    Count = 1
    Do While MyNumber <> ""
        Temp = GetHundreds(Right(MyNumber, 3))
        If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars
        If Len(MyNumber) > 3 Then
            MyNumber = Left(MyNumber, Len(MyNumber) - 3)
        Else
            MyNumber = ""
        End If
        Count = Count + 1
    Loop
    Select Case Dollars
        Case ""
            Dollars = "No Dollars"
        Case "One"
            Dollars = "One Dollar"
         Case Else
            Dollars = Dollars & " Dollars"
    End Select
    Select Case Cents
        Case ""
            Cents = " and No Cents"
        Case "One"
            Cents = " and One Cent"
              Case Else
            Cents = " and " & Cents & " Cents"
    End Select
    SpellNumber = Dollars & Cents
End Function
      
' Converts a number from 100-999 into text 
Function GetHundreds(ByVal MyNumber)
    Dim Result As String
    If Val(MyNumber) = 0 Then Exit Function
    MyNumber = Right("000" & MyNumber, 3)
    ' Convert the hundreds place.
    If Mid(MyNumber, 1, 1) <> "0" Then
        Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
    End If
    ' Convert the tens and ones place.
    If Mid(MyNumber, 2, 1) <> "0" Then
        Result = Result & GetTens(Mid(MyNumber, 2))
    Else
        Result = Result & GetDigit(Mid(MyNumber, 3))
    End If
    GetHundreds = Result
End Function
      
' Converts a number from 10 to 99 into text. 
Function GetTens(TensText)
    Dim Result As String
    Result = ""           ' Null out the temporary function value.
    If Val(Left(TensText, 1)) = 1 Then   ' If value between 10-19...
        Select Case Val(TensText)
            Case 10: Result = "Ten"
            Case 11: Result = "Eleven"
            Case 12: Result = "Twelve"
            Case 13: Result = "Thirteen"
            Case 14: Result = "Fourteen"
            Case 15: Result = "Fifteen"
            Case 16: Result = "Sixteen"
            Case 17: Result = "Seventeen"
            Case 18: Result = "Eighteen"
            Case 19: Result = "Nineteen"
            Case Else
        End Select
    Else                                 ' If value between 20-99...
        Select Case Val(Left(TensText, 1))
            Case 2: Result = "Twenty "
            Case 3: Result = "Thirty "
            Case 4: Result = "Forty "
            Case 5: Result = "Fifty "
            Case 6: Result = "Sixty "
            Case 7: Result = "Seventy "
            Case 8: Result = "Eighty "
            Case 9: Result = "Ninety "
            Case Else
        End Select
        Result = Result & GetDigit _
            (Right(TensText, 1))  ' Retrieve ones place.
    End If
    GetTens = Result
End Function
     
' Converts a number from 1 to 9 into text. 
Function GetDigit(Digit)
    Select Case Val(Digit)
        Case 1: GetDigit = "One"
        Case 2: GetDigit = "Two"
        Case 3: GetDigit = "Three"
        Case 4: GetDigit = "Four"
        Case 5: GetDigit = "Five"
        Case 6: GetDigit = "Six"
        Case 7: GetDigit = "Seven"
        Case 8: GetDigit = "Eight"
        Case 9: GetDigit = "Nine"
        Case Else: GetDigit = ""
    End Select
End Function
 
14. Kiểm tra phiên bản của Excel:

Để kiểm tra phiên bản của MS Excel mình đang sử dụng các bạn có thể dùng hàm sau:
Mã:
Val(Application.Version)

(Chỉ áp dụng cho phiên bản Excel trên Windows)

Hàm trên sẽ trả về giá trị tương ứng với các phiên bản:
  • Excel 97 sẽ trả về 8
  • Excel 2000 sẽ trả về 9
  • Excel 2002 sẽ trả về 10
  • Excel 2003 sẽ trả về 11
  • Excel 2007 sẽ trả về 12
  • Excel 2010 sẽ trả về 14
  • Excel 2011 sẽ trả về 14.1 hoặc 14.2

Lê Văn Duyệt
 
Lần chỉnh sửa cuối:
15. Kiểm tra hệ điều hành trên máy sử dụng Excel:
Cách 1:
Mã:
Application.OperatingSystem Like "*Mac*"
Ngược lại thì đó là hệ điều hành Windows.

Cách 2:
Mã:
#If Win32 Or Win64 Then
     ' Hệ điều hành Windows
       
#Else
     ' Hệ điều hành MAC

#End If

Lê Văn Duyệt
 
Lần chỉnh sửa cuối:
Web KT
Back
Top Bottom