9 Range 实用操作

‘name of worksheet
Private Const WORKSHEET_NAME = "Find Example"

‘Name of range used to flag beginning of found list
Private Const FOUND_LIST = "FoundList"

‘Name of range that contains the product look for
Private Const LOOK_FOR = "LookFor"

Sub FindExample()
    Dim ws As Worksheet
    Dim rgSearchIn As Range
    Dim rgFound As Range
    Dim sFirstFound As String
    Dim bContinue As Boolean
    
    ResetFoundList
    Set ws = ThisWorkbook.Worksheets(WORKSHEET_NAME)
    bContinue = True
    Set rgSearchIn = GetSearchRange(ws)
    
    ‘find the first instance of DLX
    ‘looking at all cells on the worksheet
    ‘looking at the whole contents of the cell
    Set rgFound = rgSearchIn.Find(ws.Range(LOOK_FOR).Value, xlValue, xlWhole)
    
    ‘if we found something, remember where we found it
    ‘this is needed to terminate the do...loop later on
    If Not rgFound Is Nothing Then sFirstFound = rgFound.Address
    
    Do Until rgFound Is Nothing Or Not bContinue
        CopyItem rgFound
        
        ‘find the next instance starting with the
        ‘cell after the one we just found
        Set rgFound = rgSearchIn.FindNext(rgFound)
        
        ‘FindNext doesn ‘t automatically stop when it
        ‘reaches the end of the worksheet - rather
        ‘it wraps around to the beginning again.
        ‘we need to prevent an endless loop by stopping
        ‘the process once we find something we‘ve already found
        If rgFound.Address = sFirstFound Then bContinue = False
    Loop
    
    Set rgSearchIn = Nothing
    Set rgFound = Nothing
    Set ws = Nothing    
End Sub

‘sets a range reference to the range containing the list - the product column
Private Function GetSearchRange(ws As Worksheet) As Range
    Dim lLastRow As Long
    
    lLastRow = ws.Cells(65536, 1).End(xlUp).Row
    Set GetSearchRange = ws.Range(ws.Cells(1, 2), ws.Cells(lLastRow, 2))    
End Function

‘copies item to found list range
Private Sub CopyItem(rgItem As Range)
    Dim rgDestination As Range
    Dim rgEntireItem As Range
    
    ‘need to use a new range object because
    ‘we will be altering this reference.
    ‘altering the reference would screw up
    ‘the find next process in the findExample
    ‘procedure. also - move off of header row
    Set rgEntireItem = rgItem.Offset(0, -1)
    
    ‘resize reference to consume all four columns associated with the found item
    Set rgEntireItem = rgEntireItem.Resize(1, 4)
    
    ‘set initial reference to found list
    Set rgDestination = rgItem.Parent.Range(FOUND_LIST)
    
    ‘find first empty row in found list
    If IsEmpty(rgDestination.Offset(1, 0)) Then
        Set rgDestination = rgDestination.Offset(1, 0)
    Else
        Set rgDestination = rgDestination.End(xlDown).Offset(1, 0)
    End If
    
    ‘copy the item to the found list
    rgEntireItem.Copy rgDestination
    Set rgDestination = Nothing
    Set rgEntireItem = Nothing   
End Sub

‘clears contents from the found list range
Private Sub ResetFoundList()
    Dim ws As Worksheet
    Dim lLastRow As Long
    Dim rgTopLeft As Range
    Dim rgBottomRight As Range
    
    Set ws = ThisWorkbook.Worksheets(WORKSHEET_NAME)
    Set rgTopLeft = ws.Range(FOUND_LIST).Offset(1, 0)
    lLastRow = ws.Range(FOUND_LIST).End(xlDown).Row
    Set rgBottomRight = ws.Cells(lLastRow, rgTopLeft.Offset(0, 3).Column)
    
    ws.Range(rgTopLeft, rgBottomRight).ClearContents
    
    Set rgTopLeft = Nothing
    Set rgBottomRight = Nothing
    Set ws = Nothing
End Sub

Sub ReplaceExample()
    Dim ws As Worksheet
    Dim rg As Range
    Dim lLastRow As Long
    
    Set ws = ThisWorkbook.Worksheets("Replace Examples")
    
    ‘determine last cell in data range
    ‘assumes the would never be an empty cell
    ‘in column 1 at the bottom of the list
    lLastRow = ws.Cells(65536, 1).End(xlUp).Row
    
    ‘Replace empty cells in 2nd & 3rd columns
    Set rg = ws.Range(ws.Cells(2, 2), ws.Cells(lLastRow, 3))
    rg.Replace "", "UNKNOWN"
    
    ‘Replace empty cells in 4th column
    Set rg = ws.Range(ws.Cells(2, 4), ws.Cells(lLastRow, 4))
    rg.Replace "", "0"
    
    Set rg = Nothing
    Set ws = Nothing
End Sub

Sub ReplaceFormats()
    ‘set formatting to look for
    With Application.FindFormat
        .Font.Bold = True
        .Font.Size = 11
    End With
    
    ‘set formatting that should be applied instead
    With Application.ReplaceFormat
        .Font.Bold = False
        .Font.Italic = True
        .Font.Size = 8
    End With
    
    ActiveSheet.Cells.Replace What:="", Replacement:="", SearchFormat:=True, ReplaceFormat:=True    
End Sub

Sub SpecialCells()
    Dim ws As Worksheet
    Dim rgSpecial As Range
    Dim rgCell As Range
    On Error Resume Next
    
    Set ws = ThisWorkbook.Worksheets("Special Cells")
    Set rgSpecial = ws.Cells.SpecialCells(xlCellTypeFormulas, xlErrors)
    
    If Not rgSpecial Is Nothing Then
        rgSpecial.Interior.Color = vbRed
    Else
        MsgBox "congratulations! " & ws.Name & " is an error-free worksheet."
    End If
    
    Set rgSpecial = Nothing
    Set rgCell = Nothing
    Set ws = Nothing
End Sub

Sub CurrentRegionExample()
    Dim ws As Worksheet
    Dim rg As Range
    
    Set ws = ThisWorkbook.Worksheets("Current Region")
    
    ‘get current regionassociated with cell A1
    Set rg = ws.Cells(1, 1).CurrentRegion
    
    ‘number of header rows
    ws.Range("I2").Value = rg.ListHeaderRows
    
    ‘number of columns
    ws.Range("I3").Value = rg.Columns.Count
    
    ‘resize to exclude header rows
    Set rg = rg.Resize(rg.Rows.Count - rg.ListHeaderRows, rg.Columns.Count).Offset(1, 0)
    
    ‘number of rows ex header rows
    ws.Range("I4").Value = rg.Rows.Count
    
    ‘number of cells ex header rows
    ws.Range("I5").Value = rg.Cells.Count
    
    ‘number empty cells ex header rows
    ws.Range("I6").Value = Application.WorksheetFunction.CountBlank(rg)
    
    ‘number of numeric cells ex header rows
    ws.Range("I7").Value = Application.WorksheetFunction.Count(rg)
    
    ‘last row
    ws.Range("I8").Value = rg.Rows.Count + rg.Cells(1, 1).Row - 1
    
    Set rg = Nothing
    Set ws = Nothing    
End Sub

Dim mnDirection As Integer
Dim mnColumn As Integer

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    ‘make sure the double-click occurred in a cell
    ‘containing column labels
    If Target.Column < 5 And Target.Row = 1 Then
        ‘see if we need to toggle the direction of the sort
        If Target.Column <> mnColumn Then
            ‘clicked in new column - record
            
            ‘which column was clicked
            mnColumn = Target.Column
            ‘set default direction
            mnDirection = xlAscending
        Else
            ‘clicked in same column toggle the sort direction
            If mnDirection = xlAscending Then
                mnDirection = xlDescending
            Else
                mnDirection = xlAscending
            End If
        End If
        TestSort
    End If
End Sub

Private Sub TestSort()
    Dim rg As Range
    
    ‘get current region associated with cell A1
    Set rg = Me.Cells(1, 1).CurrentRegion
    
    ‘ok - sort the list
    rg.Sort key1:=rg.Cells(1, mnColumn), order1:=mnDirection, Header:=xlYes
    
    Set rg = Nothing    
End Sub