Working with Ranges

Copying a Range

Sub CopyRange()

      Range("A1").Copy Range("B1")

End Sub

Sub CopyRange2()

      Workbooks("File1.xls").Sheets("Sheet1").Range("A1").Copy _

        Workbooks("File2.xls").Sheets("Sheet2").Range("A1")

End Sub

Sub CopyRange3()

      Dim Rng1 As Range, Rng2 As Range

      Set Rng1 = Workbooks("File1.xls").Sheets("Sheet1").Range("A1")

      Set Rng2 = Workbooks("File2.xls").Sheets("Sheet2").Range("A1")

      Rng1.Copy Rng2

End Sub

Sub CopyRange4()

      Range("A1:C800").Copy Range("D1")

End Sub

Moving a Range

Sub MoveRange1()

     Range("A1:C6").Cut Range("H1")

End Sub

Copying a Variably Sized Range

Sub CopyCurrentRegion2()

      Range("A1").CurrentRegion.Copy Sheets("Sheet2").Range("A1")

End Sub

Selecting or Otherwise Identifying Various Types of Ranges

Range(ActiveCell, ActiveCell.End(xlDown)).Select

Three other constants simulate key combinations in the other directions: xlUp, xlToLeft, and xlToRight.

Prompting for a Cell Value

Sub GetValue1()

      Range("A1").Value = InputBox("Enter the value")

End Sub

Sub GetValue2()

      Dim UserEntry As String

       UserEntry = InputBox("Enter the value")

      If UserEntry <> "" Then Range("A1").Value = UserEntry

End Sub

Sub GetValue3()

      Dim MinVal As Integer, MaxVal As Integer

      Dim UserEntry As String

      Dim Msg As String

      Dim DblEntry As Double

      MinVal = 1

      MaxVal = 12

      Msg = "Enter a value between "& MinVal & "and "& MaxVal

      Do

          UserEntry = InputBox(Msg)

          If UserEntry = "" Then Exit Sub

          If IsNumeric(UserEntry) Then

              DblEntry = Val(UserEntry)

              If DblEntry >= MinVal And DblEntry <= MaxVal Then Exit Do

          End If

          Msg = "Your previous entry was INVALID."

          Msg = Msg & vbNewLine

          Msg = Msg & "Enter a value between "& MinVal & "and "& MaxVal

      Loop

      ActiveSheet.Range("A1").Value = UserEntryEnd Sub

Entering a Value in the Next Empty Cell

Sub GetData()

      Dim NextRow As Long

      Dim Entry1 As String, Entry2 As String

  Do

      NextRow = Range("A65536").End(xlUp).Row + 1

      Entry1 = InputBox("Enter the name")

      If Entry1 = "" Then Exit Sub

    Entry2 = InputBox("Enter the amount")

      If Entry2 = "" Then Exit Sub

      Cells(NextRow, 1) = Entry1

      Cells(NextRow, 2) = Entry2

  Loop

End Sub

Pausing a Macro to Get a User-Selected Range

Sub GetUserRange()

      Dim UserRange As Range

      Output = 565

      Prompt = "Select a cell for the output."

      Title = "Select a cell"

'     Display the Input Box

      On Error Resume Next

      Set UserRange = Application.InputBox( _

          Prompt:=Prompt, _

          Title:=Title, _

          Default:=ActiveCell.Address, _

          Type:=8) 'Range selection

      On Error GoTo 0

'     Was the Input Box canceled?

      If UserRange Is Nothing Then

          MsgBox "Canceled."

      Else

          UserRange.Range("A1") = Output

      End If

End Sub

Counting Selected Cells:

MsgBox Selection.Count

CellCount = Range("data").Count

Selection.Columns.Count

RowCount = Range("data").Rows.Count

Determining the Type of Selected Range

NumAreas = Selection.Areas.Count

Function AreaType(RangeArea As Range) As String

'     Returns the type of a range in an area

      Select Case True

          Case RangeArea.Cells.Count = 1

              AreaType = "Cell"

          Case RangeArea.Count = Cells.Count

              AreaType = "Worksheet"

          Case RangeArea.Rows.Count = Cells.Rows.Count

              AreaType = "Column"

          Case RangeArea.Columns.Count = Cells.Columns.Count

              AreaType = "Row"

          Case Else

              AreaType = "Block"

      End Select

End Function

Looping through a Selected Range Efficiently

Listing 11-1: Coloring All Negative Cells' Backgrounds Red

Sub SelectiveColor1()

'     Makes cell background red if the value is negative

      Dim cell As Range

      If TypeName(Selection) <> "Range" Then Exit Sub

      Const REDINDEX = 3

      Application.ScreenUpdating = False

      For Each cell In Selection

          If cell.Value < 0 Then

            cell.Interior.ColorIndex = REDINDEX

          Else

            cell.Interior.ColorIndex = xlNone

          End If

      Next cell

End Sub 

Listing 11-2: Improving This Procedure to Include Wider, Multiple-column Ranges

Sub SelectiveColor2()

'     Makes cell background red if the value is negative

      Dim cell As Range

      Dim FormulaCells As Range

      Dim ConstantCells As Range

      Const REDINDEX = 3 

'     Ignore errors

      On Error Resume Next

      Application.ScreenUpdating = False

'     Create subsets of original selection

      Set FormulaCells = Selection.SpecialCells (xlFormulas, xlNumbers)

      Set ConstantCells = Selection.SpecialCells (xlConstants, xlNumbers)

      On Error GoTo 0

'     Process the formula cells

      If Not FormulaCells Is Nothing Then

          For Each cell In FormulaCells

              If cell.Value < 0 Then

                 cell.Interior.ColorIndex = REDINDEX

              Else

                cell.Interior.ColorIndex = xlNone

              End If

          Next cell

      End If

'     Process the constant cells

      If Not ConstantCells Is Nothing Then

          For Each cell In ConstantCells

              If cell.Value < 0 Then

                cell.Interior.ColorIndex = REDINDEX

              Else

                cell.Interior.ColorIndex = xlNone

              End If

          Next cell

      End If

End Sub