8 Range对象（一）

Sub ReferringToRangesI() 
    Dim rg As Range 
     
    ‘ActiveCell is a range representing the 
    ‘active cell. there can be one and 
    ‘only one active cell. 
    Debug.Print Application.ActiveCell.Address 
     
    ‘selection refers to a range representing 
    ‘all of the selected cells. there can be 
    ‘one or more cells in the range. 
    Debug.Print Application.Selection.Address 
     
    ‘application.Range works on the active 
    ‘worksheet 
    ThisWorkbook.Worksheets(1).Activate 
    Set rg = Application.Range("D5") 
    Debug.Print "worksheets 1 is active" 
    Debug.Print rg.Address 
    Debug.Print rg.Parent.Name 
     
    ThisWorkbook.Worksheets(2).Activate 
    Set rg = Application.Range("D5") 
    Debug.Print "worksheets 2 is active" 
    Debug.Print rg.Address 
    Debug.Print rg.Parent.Name
    
    Set rg = Nothing
End Sub

Application.Range("D5") 
Application.Range("A1:C5") 
Application.Range("A:A") 
Application.Range("3:3") 
Application.Range("A1:D5","D6:F10") 

Sub UsingCells() 
    Dim rg As Range 
    Dim nRow As Integer 
    Dim nColumn As Integer 
    Dim ws As Worksheet 
     
    Set ws = ThisWorkbook.Sheets(1) 
     
    For nRow = 1 To 10 
        For nColumn = 1 To 10 
            Set rg = ws.Cells(nRow, nColumn) 
            rg.Value = rg.Address 
        Next 
    Next 
     
    Set rg = Nothing 
    Set ws = Nothing 
End Sub

Sub UsingRange() 
    Dim ws As Worksheet 
    Dim rg As Range 
     
    Set ws = ThisWorkbook.Worksheets(1)

    ‘specifying a range using Cells 
    ‘this range is equivalent to A1:J10 
    Set rg = ws.Range(ws.Cells(1, 1), ws.Cells(10, 10)) 
    ‘sets the value of each cell in the range to 1 
    rg.Value = 1 
     
    Set rg = ws.Range("D4", "E5") 
    rg.Font.Bold = True 
    ws.Range("A1:B2").HorizontalAlignment = xlLeft 
     
    Set rg = Nothing 
    Set ws = Nothing 
End Sub

Set rg = ws.Range(ws.Cells(1, 1), ws.Cells(10, 10))

‘Test the ListWorkbookNmaes procedure 
‘outputs to cell A2 on the 2nd worksheet in the workbook 
Sub TestListNames() 
    ListWorkbookNames ThisWorkbook, ThisWorkbook.Worksheets(2).Range("A2") 
End Sub 

Sub ListWorkbookNames(wb As Workbook, rgListStart As Range) 
    Dim nm As Name 
    For Each nm In wb.Names 
        ‘print out the name of the range 
        rgListStart.Value = nm.Name 
         
        ‘print out what the range refers to 
        ‘the ‘ is required so that excel doesn‘t consider it as a formula 
        rgListStart.Offset(0, 1).Value = "‘" & nm.RefersTo 
        rgListStart.Offset(0, 2).Value = "‘" & nm.Value 
        rgListStart.Offset(0, 3).Value = nm.RefersToRange 
         
        ‘set rgListStart to refer to the cell the next row down. 
        Set rgListStart = rgListStart.Offset(1, 0) 
    Next 
End Sub 

‘checks for the existence of a named range on a worksheet 
Function RangeNameExists(ws As Worksheet, sName As String) As Boolean 
    Dim s As String 
    On Error GoTo ErrHandler 
    
    s = ws.Range(sName).Address 
    RangeNameExists = True 
    Exit Function
ErrHandler: 
    RangeNameExists = False
End Function 

Sub ValidateNamedRangeExample() 
    If RangeNameExists(ThisWorkbook.Worksheets(1), "Test") Then 
        MsgBox "The name exists, it refers to: " & ThisWorkbook.Names("Test").RefersTo, vbOKOnly 
    Else 
        MsgBox "the name does not exist", vbOKOnly 
    End If 
    If RangeNameExists(ThisWorkbook.Worksheets(1), "djfs") Then 
        MsgBox "The name exists, it refers to: " & ThisWorkbook.Worksheets(1).Names("djfs").RefersTo, vbOKOnly 
    Else 
        MsgBox "the name does not exist", vbOKOnly      
    End If      
End Sub 

Sub ListExample() 
    FilterYear 2000 
End Sub 

Sub Reset() 
    With ThisWorkbook.Worksheets("List Example") 
        .Rows.Hidden = False 
        .Rows.Font.Bold = False 
        .Rows(1).Font.Bold = True          
    End With 
End Sub 

Sub FilterYear(nYear As Integer) 
    Dim rg As Range 
    Dim nMileageOffset As Integer 
     
    ‘1st row is column header so start with 2nd row 
    Set rg = ThisWorkbook.Worksheets("List Example").Range("A2") 
    nMileageOffset = 6 
     
    ‘go until we bump into first empty cell 
    Do Until IsEmpty(rg) 
        If rg.Value < nYear Then 
            rg.EntireRow.Hidden = True 
        Else 
            ‘check milage 
            If rg.Offset(0, nMileageOffset).Value < 40000 Then 
                rg.Offset(0, nMileageOffset).Font.Bold = True 
            Else 
                rg.Offset(0, nMileageOffset).Font.Bold = False 
            End If 
            rg.EntireRow.Hidden = False 
        End If 
        ‘move down to the next row 
        Set rg = rg.Offset(1, 0) 
    Loop 

    Set rg = Nothing 
End Sub

Sub ExperimentWithEnd() 
    Dim ws As Worksheet 
    Dim rg As Range 
     
    Set ws = ThisWorkbook.Worksheets(1) 
    Set rg = ws.Cells(1, 1) 
     
    ws.Cells(1, 8).Value = "rg.address = " & rg.Address 
    ws.Cells(2, 8).Value = "rg.End(xlDown).Address = " & rg.End(xlDown).Address 
    ws.Cells(3, 8).Value = "rg.End(xlDown).End(xlDown).Address = " & rg.End(xlDown).End(xlDown).Address 
    ws.Cells(4, 8).Value = "rg.End(xlToRight).Address = " & rg.End(xlToRight).Address 
     
    Set rg = Nothing 
    Set ws = Nothing 
End Sub 

‘returns a range object that represents the last 
‘non-empty cell in the same column 
Function GetLastCellInColumn(rg As Range) As Range 
    Dim lMaxRows As Long 
     
    lMaxRows = ThisWorkbook.Worksheets(1).Rows.Count 
     
    ‘make sure the last cell in the column is empty 
    If IsEmpty(rg.Parent.Cells(lMaxRows, rg.Column)) Then 
        Set GetLastCellInColumn = rg.Parent.Cells(lMaxRows, rg.Column).End(xlUp) 
    Else 
        Set GetLastCellInColumn = rg.Parent.Cells(lMaxRows, rg.Column) 
    End If 
End Function 

‘returns a range object that represents the last 
‘non-empty cell in the same row 
Function GetLastCellInRow(rg As Range) As Range 
    Dim lMaxColumns As Long 
     
    lMaxColumns = ThisWorkbook.Worksheets(1).Columns.Count 
     
    ‘make sure the last cell in the row is empty 
    If IsEmpty(rg.Parent.Cells(rg.Row, lMaxColumns)) Then 
        Set GetLastCellInRow = rg.Parent.Cells(rg.Row, lMaxColumns).End(xlToLeft) 
    Else 
        Set GetLastCellInRow = rg.Parent.Cells(rg.Row, lMaxColumns) 
    End If 
End Function

‘returns a number that represents the last 
‘nonempty cell in the same column 
‘callable from a worksheet 
Function GetLastUsedRow(rg As Range) As Long 
    Dim lMaxRows As Long 
     
    lMaxRows = ThisWorkbook.Worksheets(1).Rows.Count 
    ‘make sure the last cell in the column is empty 
    If IsEmpty(rg.Parent.Cells(lMaxRows, rg.Column)) Then 
        GetLastUsedRow = rg.Parent.Cells(lMaxRows, rg.Column).End(xlUp).Row 
    Else 
        GetLastUsedRow = rg.Parent.Cells(lMaxRows, rg.Column).Row 
    End If 
     
End Function 

‘returns a number that represents the last 
‘nonempty cell in the same row 
‘callable from a worksheet 
Function GetLastUsedColumn(rg As Range) As Long 
    Dim lMaxColumns As Long 
     
    lMaxColumns = ThisWorkbook.Worksheets(1).Columns.Count 
    If IsEmpty(rg.Parent.Cells(rg.Row, lMaxColumns)) Then 
        GetLastUsedColumn = rg.Parent.Cells(rg.Row, lMaxColumns).End(xlToLeft).Column 
    Else 
        GetLastUsedColumn = rg.Parent.Cells(rg.Row, lMaxColumns).Column 
    End If 
End Function

‘this is procedures are generally error prone 
‘and unnecessarily difficult to maintain/modify 
Sub RigidFormattingProcedure() 
    ‘Activate Test Report worksheet 
    ThisWorkbook.Worksheets("Test Report").Activate 
    ‘make text in first column bold 
    ActiveSheet.Range("A:A").Font.Bold = True 
    ‘widen first column to display text 
    ActiveSheet.Range("A:A").EntireColumn.AutoFit 
    ‘format date on report 
    ActiveSheet.Range("A2").NumberFormat = "mmm-yy" 
    ‘Make column headings bold 
    ActiveSheet.Range("6:6").Font.Bold = True 
     
    ‘add & format totals 
    ActiveSheet.Range("N7:N15").Formula = "=sum(rc[-12]:rc[-1])" 
    ActiveSheet.Range("N7:N15").Font.Bold = True 
     
    ActiveSheet.Range("B16:N16").Formula = "=sum(r[-9]c:r[-1]c)" 
    ActiveSheet.Range("B16:N16").Font.Bold = True 
     
    ‘format data range 
    ActiveSheet.Range("B7:N16").NumberFormat = "#,##0"      
End Sub 

Sub RigidProcedureDeRigidized() 
    Dim ws As Worksheet 
    If Not WorksheetExists(ThisWorkbook, "Test Report") Then 
        MsgBox "can‘t find required worksheet ‘test report‘", vbOKOnly 
        Exit Sub 
    End If 
     
    Set ws = ThisWorkbook.Worksheets("Test Report") 
     
    If RangeNameExists(ws, "report_title") Then 
        ws.Range("report_title").Font.Bold = True 
    End If 
     
    If RangeNameExists(ws, "report_date") Then 
        With ws.Range("report_date") 
            .Font.Bold = True 
            .NumberFormat = "mmm-yy" 
            .EntireColumn.AutoFit 
        End With 
    End If 
     
    If RangeNameExists(ws, "row_heading") Then 
        ws.Range("row_heading").Font.Bold = True 
    End If 
     
    If RangeNameExists(ws, "column_heading") Then 
        ws.Range("column_heading").Font.Bold = True 
    End If 
     
    If RangeNameExists(ws, "DATA") Then 
        ws.Range("DATA").NumberFormat = "#,##0" 
    End If 
     
    If RangeNameExists(ws, "COLUMN_TOTAL") Then 
        With ws.Range("COLUMN_TOTAL") 
            .Formula = "=sum(r[-9]c:r[-1]c)" 
            .Font.Bold = True 
            .NumberFormat = "#,##0" 
        End With 
    End If 
     
    If RangeNameExists(ws, "ROW_TOTAL") Then 
        With ws.Range("ROW_TOTAL") 
            .Formula = "=sum(rc[-12]:rc[-1])" 
            .Font.Bold = True 
            .NumberFormat = "#,##0" 
        End With 
    End If 
         
    Set ws = Nothing 
End Sub 

Function ReadCurrencyCell(rg As Range) As Currency 
    Dim cValue As Currency 
    cValue = 0 
     
    On Error GoTo ErrHandler 
     
    If IsEmpty(rg) Then GoTo ExitFunction 
    If Not IsNumeric(rg) Then GoTo ExitFunction 
     
    cValue = rg.Value 
 
ExitFunction: 
    ReadCurrencyCell = cValue 
    Exit Function 
 
ErrHandler: 
    ReadCurrencyCell = 0 
End Function