Some Useful Macro Procedure-1

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

Duplicating rows a variable number of times

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