9 Range 实用操作

9.1 剪切、复制和粘贴来移动数据

sourceRange.Cut [Destination]

如果指定Destination，相当于Ctrl^X(sourceRange) & Ctrl^V(Destination)。如果没有指定就相当于Ctrl^X(sourceRange)。

sourceRange.Copy [Destination]

如果指定Destination，相当于Ctrl^C(sourceRange) & Ctrl^V(Destination)。如果没有指定就相当于Ctrl^C(sourceRange)。

Application.CutCopyMode = False 可以关闭cut/copy时，单元格周围移动的虚线框。

destinationRange.PasteSpecial

    [paste as xlPasteType],

    [operation as xlPasteSpecialOperation],

    [SkipBlanks as boolean],

    [Transpose]

其中:

Paste := [xlPasteAll]|xlPasteAllExceptBorders|xlPasteColumnWidths|xlPasteComments|xlPasteFormats|xlPasteFormulas

              |xlPasteFormulasAndNumberFormats|xlPasteValidation|xlPasteValues|xlPasteValuesAndNumberFormats

operation := [xlPasteSpecialOperationNone]|xlPasteSpecialOperationAdd|xlPasteSpecialOperationDivide|xlPasteSpecialOperationMultiply|xlPasteSpecialOperationSubstract

operation 指的是是否对源范围内的数值进行简单的算术运算。

skipBlanks 指是否忽略源范围的空白单元格，默认是False，不忽略。

Transpose 指是否转置，默认为False，不转置。

rangeToDelete.Delete [Shift as XlDeleteShiftDirection]

其中：

    Shift := xlShiftToLeft | xlShiftUp。Used only with Range objects. Specifies how to shift cells to replace deleted cells. Can be one of the following XlDeleteShiftDirection constants: xlShiftToLeft or xlShiftUp. If this argument is omitted, Microsoft Excel decides based on the shape of the range.

9.2 查找我们的目标

expression.Find(What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat)

参见：http://msdn.microsoft.com/en-us/library/ff839746(v=office.15).aspx

expression.FindNext(After)

expression.FindPrevious(After)

参见：http://msdn.microsoft.com/en-us/library/ff196143(v=office.15).aspx

以及：http://msdn.microsoft.com/en-us/library/ff838614(v=office.15).aspx

代码清单9.1：使用Find和Copy方法 

'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

  

9.3 使用Replace替换

expression.Replace(What, Replacement, LookAt, SearchOrder, MatchCase, MatchByte, SearchFormat, ReplaceFormat)

参见：http://msdn.microsoft.com/en-us/library/ff194086(v=office.15).aspx

代码清单9.2：使用Replace以程序设计的方式设置正确的范围 

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

代码清单9.3：使用Replace替换格式 

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

9.4 喜欢它的特别调味品吗？

expression.SpecialCells(Type, Value)

参见：http://msdn.microsoft.com/en-us/library/ff196157(v=office.15).aspx

代码清单9.4：当使用SpecialCells时，使用错误处理

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

9.5 CurrentRegion：一个有用的捷径

Range对象的CurrentRegion属性

参见：http://msdn.microsoft.com/en-us/library/ff196678(v=office.15).aspx

Range对象的ListHeaderRows属性

参见：http://msdn.microsoft.com/en-us/library/ff839644(v=office.15).aspx

代码清单9.5：调用CurrentRegion观察一个列表的有用特征

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

9.6 列表简单排序

expression.Sort(Key1, Order1, Key2, Type, Order2, Key3, Order3, Header, OrderCustom, MatchCase, Orientation, SortMethod, DataOption1, DataOption2, DataOption3)

参见：http://msdn.microsoft.com/en-us/library/ff840646(v=office.15).aspx

中文排序：

expression.SortSpecial(SortMethod, Key1, Order1, Type, Key2, Order2, Key3, Order3, Header, OrderCustom, MatchCase, Orientation, DataOption1, DataOption2, DataOption3)

参见：http://msdn.microsoft.com/en-us/library/ff822807(v=office.15).aspx

代码清单9.6：增加工作表列表的可单击排序

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