首页 > 其他 > 详细

9 Range 实用操作

时间:2014-02-28 07:23:59      阅读:485      评论:0      收藏:0      [点我收藏+]

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 查找我们的目标

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

bubuko.com,布布扣
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
bubuko.com,布布扣

 

 

9.3 使用Replace替换

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

bubuko.com,布布扣
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
bubuko.com,布布扣

 

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

bubuko.com,布布扣
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
bubuko.com,布布扣

 

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

代码清单9.4:当使用SpecialCells时,使用错误处理

bubuko.com,布布扣
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
bubuko.com,布布扣

 

9.5 CurrentRegion:一个有用的捷径

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

bubuko.com,布布扣
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
bubuko.com,布布扣

 

9.6 列表简单排序

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

bubuko.com,布布扣
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
bubuko.com,布布扣

9 Range 实用操作,布布扣,bubuko.com

9 Range 实用操作

原文:http://www.cnblogs.com/cuishengli/p/3571290.html

(0)
(0)
   
举报
评论 一句话评论(0
关于我们 - 联系我们 - 留言反馈 - 联系我们:wmxa8@hotmail.com
© 2014 bubuko.com 版权所有
打开技术之扣,分享程序人生!