15 Useful functions – 15 hàm hữu ích trong lập trình Macro VBA Excel

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

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

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

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

Function FileExists(ByVal fname As String) As Boolean
    Set fs = CreateObject("Scripting.FileSystemObject")
    FileExists = fs.FileExists(fname)
End Function

Function bFileExists(rsFullPath As String) As Boolean
  bFileExists = CBool(Len(Dir$(rsFullPath)) > 0)
End Function

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

Function bWorkbookIsOpen(rsWbkName As String) As Boolean
On Error Resume Next
  bWorkbookIsOpen = CBool(Len(Workbooks(rsWbkName).Name) > 0)
End Function

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

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:MyTestvolker2.xls") Then
        Workbooks.Open "C:MyTestvolker2.xls"
    End If
End Sub

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

Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

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

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?

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.