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]

其中:

|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(, ).End(xlUp).Row

    Set GetSearchRange = ws.Range(ws.Cells(, ), ws.Cells(lLastRow, ))

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(, -)

    'resize reference to consume all four columns associated with the found item

    Set rgEntireItem = rgEntireItem.Resize(, )

    'set initial reference to found list

    Set rgDestination = rgItem.Parent.Range(FOUND_LIST)

    'find first empty row in found list

    If IsEmpty(rgDestination.Offset(, )) Then

        Set rgDestination = rgDestination.Offset(, )

    Else

        Set rgDestination = rgDestination.End(xlDown).Offset(, )

    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(, )

    lLastRow = ws.Range(FOUND_LIST).End(xlDown).Row

    Set rgBottomRight = ws.Cells(lLastRow, rgTopLeft.Offset(, ).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(, ).End(xlUp).Row

    'Replace empty cells in 2nd & 3rd columns

    Set rg = ws.Range(ws.Cells(, ), ws.Cells(lLastRow, ))

    rg.Replace "", "UNKNOWN"

    'Replace empty cells in 4th column

    Set rg = ws.Range(ws.Cells(, ), ws.Cells(lLastRow, ))

    rg.Replace "", ""

    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 =

    End With

    'set formatting that should be applied instead

    With Application.ReplaceFormat

        .Font.Bold = False

        .Font.Italic = True

        .Font.Size =

    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(, ).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(, )

    '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(, ).Row - 

    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 <  And Target.Row =  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(, ).CurrentRegion

    'ok - sort the list

    rg.Sort key1:=rg.Cells(, mnColumn), order1:=mnDirection, Header:=xlYes

    Set rg = Nothing

End Sub

巴特西