Some
Useful Macro Procedure
Copying
a variably sized range
In many cases, you need to copy a range
of cells, but you don’t know the exact row and column dimensions of the range.
The following macro demonstrates how to
copy this range from Sheet1 to Sheet2 (beginning at cell A1). It uses the CurrentRegion
property, which returns a Range object that corresponds to the block of cells
around a particular cell (in this case, A1).
Sub
CopyCurrentRegion2()
Range(“A1”).CurrentRegion.Copy
Sheets(“Sheet2”).Range(“A1”)
End Sub
Prompting
for a cell value
The following procedure demonstrates
how to ask the user for a value and then insert it into cell A1 of the active
worksheet:
Sub GetValue()
Range(“A1”).Value
= InputBox(“Enter the value”)
End Sub
This procedure has a problem, however.
If the user clicks the Cancel button in the input box, the procedure deletes
any data already in the cell. The following modification takes no action if the
Cancel button is clicked:
Modified
version of above Example
Sub GetValue ()
Dim UserEntry As
Variant
UserEntry =
InputBox(“Enter the value”)
If UserEntry <>
“” Then Range(“A1”).Value = UserEntry
End Sub
Entering
a value in the next empty cell (DATA ENTRY)
A common requirement is to enter a
value or data into the next empty cell in a column or row. The following
example prompts the user for a name and a value and then enters the data into
the next empty row.
Sub DataEntry()
Dim NextRow As Long
Dim Entry1 As String,
Entry2 As String, Entry3 As String, Entry4 As String, Entry5 As String
Do
‘Determine next empty
row
NextRow =
Cells(Rows.Count, 1).End(xlUp).Row + 1
'Creating Header
Cells(1, 1).Value =
"Name"
Cells(1, 2).Value =
"Gender"
Cells(1, 3).Value =
"Address"
Cells(1, 4).Value =
"Phone Number"
Cells(1, 5).Value =
"EMail ID"
‘ Prompt for the data
Entry1 =
InputBox(“Enter the Name”)
If Entry1 = “” Then
Exit Sub
Entry2 = InputBox(“Gender”)
If Entry2 = “” Then
Exit Sub
Entry3 = InputBox(“Address”)
If Entry3 = “” Then
Exit Sub
Entry4 = InputBox(“Phone
Number”)
If Entry4 = “” Then
Exit Sub
Entry5 = InputBox(“Email
ID”)
If Entry5 = “” Then
Exit Sub
‘ Write the data
Cells(NextRow, 1) =
Entry1
Cells(NextRow, 2) =
Entry2
Cells(NextRow, 3) =
Entry3
Cells(NextRow, 4) =
Entry4
Cells(NextRow, 5) =
Entry5
Loop
End Sub
Get a
user-selected range
In some situations, you may need an
interactive macro. For example, you can create a macro that pauses while the
user specifies a range of cells. The procedure in this section describes how to
do this with Excel’s InputBox method.
Sub GetUserRange()
Dim UserRange As Range
Prompt = “Select a
range for the random numbers.”
Title = “Select a
range”
‘ 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.Formula = “=RAND()”
End If
End Sub
Looping
through a selected range efficiently
A common task is to create a macro that
evaluates each cell in a range and performs an operation if the cell meets a
certain criterion. The procedure that follows is an example of such a macro.
The ColorNegative procedure sets the cell’s background color to red for cells
that contain a negative value. For non-negative value cells, it sets the
background color to none.
Sub ColorNegative3()
‘ Makes negative cells
red
Dim FormulaCells As
Range, ConstantCells As Range
Dim cell As Range
If TypeName(Selection)
<> “Range” Then Exit Sub
Application.ScreenUpdating
= False
‘ Create subsets of
original selection
On Error Resume Next
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.Color
= RGB(255, 0, 0)
Else
cell.Interior.Color
= 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.Color
= RGB(255, 0, 0)
Else
cell.Interior.Color
= xlNone
End If
Next
cell
End If
End Sub
The example in this section
demonstrates how to use VBA to create duplicates of a row. Take an Example
Column A contains the name, and column B contains the number of tickets
purchased by each person.
Name
|
No of Ticket
|
Sumit
|
1
|
Punam
|
3
|
Sandeep
|
5
|
Amit
|
9
|
The goal is to duplicate the rows so
that each person will have a row for each ticket purchased. For example, Sandeep
purchased five tickets, so he should have five rows. The procedure to insert
the new rows is shown below:
Sub InsertRows()
Dim cell As Range
' 1st cell with number
of tickets
Set cell =
Range("B2")
Do While Not
IsEmpty(cell)
If cell > 1 Then
Range(cell.Offset(1,
0), cell.Offset(cell.Value - 1, _
0)).EntireRow.Insert
Range(cell,
cell.Offset(cell.Value - 1, 1)).EntireRow.FillDown
End If
Set cell =
cell.Offset(cell.Value, 0)
Loop
End Sub
The cell object variable is initialized
to cell B2, the first cell that has a number. The loop inserts new rows and
then copies the row using the FillDown method. The cell variable is incremented
to the next person, and the loop continues until an empty cell is encountered. Below
is the output shows the worksheet after running this procedure.
Name
|
No of Ticket
|
Sumit
|
1
|
Punam
|
3
|
Punam
|
3
|
Punam
|
3
|
Sandeep
|
5
|
Sandeep
|
5
|
Sandeep
|
5
|
Sandeep
|
5
|
Sandeep
|
5
|
Amit
|
9
|
Amit
|
9
|
Amit
|
9
|
Amit
|
9
|
Amit
|
9
|
Amit
|
9
|
Amit
|
9
|
Amit
|
9
|
Amit
|
9
|
Writing Ranges
This code inserts the values into an
array and then uses a single statement to transfer the contents of an
array to the range.
Sub ArrayFillRange()
‘ Fill a range by
transferring an array
Dim CellsDown As Long,
CellsAcross As Integer
Dim i As Long, j As
Integer
Dim StartTime As
Double
Dim TempArray() As
Long
Dim TheRange As Range
Dim CurrVal As Long
‘ Get the dimensions
CellsDown =
InputBox(“How many cells down?”)
If CellsDown = 0 Then
Exit Sub
CellsAcross =
InputBox(“How many cells across?”)
If CellsAcross = 0
Then Exit Sub
‘ Record starting time
StartTime = Timer
‘ Redimension
temporary array
ReDim TempArray(1 To
CellsDown, 1 To CellsAcross)
‘ Set worksheet range
Set TheRange =
ActiveCell.Range(Cells(1, 1), _
Cells(CellsDown,
CellsAcross))
‘ Fill the temporary
array
CurrVal = 0
Application.ScreenUpdating
= False
For i = 1 To CellsDown
For j = 1 To
CellsAcross
TempArray(i, j) =
CurrVal + 1
CurrVal = CurrVal + 1
Next j
Next i
‘ Transfer temporary
array to worksheet
TheRange.Value =
TempArray
‘ Display elapsed time
Application.ScreenUpdating
= True
MsgBox Format(Timer -
StartTime, “00.00”) & “ seconds”
End Sub
More Example in Some Useful Macro Procedure-2
No comments:
Post a Comment