To Search a List for a Specific Record

This code moves down column A to the end of the list:

   Sub Test3()
      Dim x As String
      Dim found As Boolean
      ' Select first line of data.
      Range("A2").Select
      ' Set search variable value.
      x = "test"
      ' Set Boolean variable "found" to false.
      found = False
      ' Set Do loop to stop at empty cell.
      Do Until IsEmpty(ActiveCell)
         ' Check active cell for search value.
         If ActiveCell.Value = x Then
            found = TRUE
            Exit Do
         End If
         ' Step down 1 row from present location.
         ActiveCell.Offset(1, 0).Select
      Loop
   ' Check for found.
      If found = True Then
         Msgbox "Value found in cell " & ActiveCell.Address
      Else
         Msgbox "Value not found"
      End If
   End Sub
    

To Search a Dynamic List or a List with an Unknown Number of Rows

This code moves down column A to the end of the list. (This code assumes that each cell in column A contains an entry until the end.)

   Sub Test2()
      ' Select cell A2, *first line of data*.
      Range("A2").Select
      ' Set Do loop to stop when an empty cell is reached.
      Do Until IsEmpty(ActiveCell)
         ' Insert your code here.
         ' Step down 1 row from present location.
         ActiveCell.Offset(1, 0).Select
      Loop
   End Sub
 

Note:-  If there are empty cells in column A throughout the data, 

modify this code to account for this condition. Make sure that the empty cells are

 a consistent distance apart. For example, if every other cell in column A is

 empty (for example, this situation may occur if every 'record' uses two rows,

 with the second row indented one cell), this loop can be modified as follows:  

      ' Set Do loop to stop when two consecutive empty cells are reached.
      Do Until IsEmpty(ActiveCell) and IsEmpty(ActiveCell.Offset(1, 0))
         ' Insert your code here.
         '
         ' Step down 2 rows from present location.
         ActiveCell.Offset(2, 0).Select
      Loop
    

To Search a List with a Constant, Known Number of Rows

This code moves down column A to the end of the list:  

Sub Test1()
      Dim x As Integer
      ' Set numrows = number of rows of data.
      NumRows = Range("A2", Range("A2").End(xldown)).Rows.Count
      ' Select cell a1.
      Range("A2").Select
      ' Establish "For" loop to loop "numrows" number of times.
      For x = 1 To NumRows
         ' Insert your code here.
         ' Selects cell down 1 row from active cell.
         ActiveCell.Offset(1, 0).Select
      Next
   End Sub

Referring to Cells by Using Index Numbers

You can use the Cells property to refer to a single cell by using row and column index numbers. This property returns a Range object that represents a single cell. In the following example, Cells(6,1) returns cell A6 on Sheet1. The Value property is then set to 10.

Sub EnterValue()
    Worksheets("Sheet1").Cells(6, 1).Value = 10
End Sub
  

The Cells property works well for looping through a range of cells, because you can substitute variables for the index numbers, as shown in the following example.

Sub CycleThrough()
    Dim Counter As Integer
    For Counter = 1 To 20
        Worksheets("Sheet1").Cells(Counter, 3).Value = Counter
    Next Counter
End Sub
  

Referring to Cells and Ranges by Using A1 Notation

ou can refer to a cell or range of cells in the A1 reference style by using the Range property. The following
subroutine changes the format of cells A1:D5 to bold.

Sub FormatRange()
    Workbooks("Book1").Sheets("Sheet1").Range("A1:D5") _
        .Font.Bold = True
End Sub
  

The following table illustrates some A1-style references using the Range property.

Reference	Meaning
Range("A1")	Cell A1
Range("A1:B5")	Cells A1 through B5
Range("C5:D9,G9:H16")	A multiple-area selection
Range("A:A")	Column A
Range("1:1")	Row 1
Range("A:C")	Columns A through C
Range("1:5")	Rows 1 through 5
Range("1:1,3:3,8:8")	Rows 1, 3, and 8
Range("A:A,C:C,F:F")	Columns A, C, and F

Opening an HTML Document in Microsoft Excel

To edit an HTML document in Excel, first open the document by using the Open method. The following example opens the file "C:\Reports\1997_Q4.htm" for editing.

Workbooks.Open Filename:="C:\Reports\1997_Q4.htm"
  

After opening the file, you can customize the appearance, content, browser support, editing support, graphics formats, screen resolution, file organization, and encoding of the HTML document by setting properties of the DefaultWebOptions and WebOptions objects.

Customizing the Web Page

You can customize the appearance, content, browser support, editing support, graphics formats, screen resolution, file organization, and encoding of the HTML document by setting properties of the DefaultWebOptions object and the WebOptions object. The DefaultWebOptions object contains application-level properties. These settings are overridden by any workbook-level property settings that have the same names (these are contained in the WebOptions object).
After setting the attributes, you can use the Publish method to save the workbook, worksheet, chart, range, query table, PivotTable report, print area, or AutoFilter range to a Web page. The following example sets various application-level properties and then sets the AllowPNG property of the active workbook, overriding the application-level default setting. Finally, the example saves the range as "C:\Reports\1998_Q1.htm."

With Application.DefaultWebOptions
    .RelyonVML = True
    .AllowPNG = True
    .PixelsPerInch = 96
End With
With ActiveWorkbook
    .WebOptions.AllowPNG = False
    With .PublishObjects(1)
        .FileName = "C:\Reports\1998_Q1.htm"
        .Publish
    End With
End With
  

You can also save the files directly to a Web server. The following example saves a range to a Web server, giving the Web page the URL address http://example.homepage.com/annualreport.htm.

With ActiveWorkbook
    With .WebOptions
        .RelyonVML = True
        .PixelsPerInch = 96
    End With
    With .PublishObjects(1)
        .FileName = _
        "http://example.homepage.com/annualreport.htm"
        .Publish
    End With
End With
  

Saving Documents as Web Pages

Saving a document as a Web page is the process of creating and saving an HTML file and any supporting files. To do this, use the SaveAs method, as shown in the following example, which saves the active workbook as C:\Reports\myfile.htm.

ActiveWorkbook.SaveAs _
    Filename:="C:\Reports\myfile.htm", _
    FileFormat:=xlHTML
  

Referring to Sheets by Name

You can identify sheets by name using the Worksheets and Charts properties. The following statements activate various sheets in the active workbook.

Worksheets("Sheet1").Activate
Charts("Chart1").Activate
  

DialogSheets("Dialog1").Activate
  

You can use the Sheets property to return a worksheet, chart, module, or dialog sheet; the Sheets collection contains all of these. The following example activates the sheet named "Chart1" in the active workbook.

Sub ActivateChart()
    Sheets("Chart1").Activate
End Sub
  

Note   Charts embedded in a worksheet are members of the ChartObjects collection, whereas charts that exist on their own sheets belong to the Charts collection.

Referring to Sheets by Index Number

An index number is a sequential number assigned to a sheet, based on the position of its sheet tab (counting from the left) among sheets of the same type. The following procedure uses the Worksheets property to activate worksheet one in the active workbook.

Sub FirstOne()
    Worksheets(1).Activate
End Sub
  

If you want to work with all types of sheets (worksheets, charts, modules, and dialog sheets), use the Sheets property. The following procedure activates sheet four in the workbook.

Sub FourthOne()
    Sheets(4).Activate
End Sub
  

Note  The index order can change if you move, add, or delete sheets.

Opening a Workbook

When you open a workbook using the Open method, it becomes a member of the Workbooks collection. The following procedure opens a workbook named MyBook.xls located in the folder named MyFolder on drive C.

Sub OpenUp()
    Workbooks.Open("C:\MyFolder\MyBook.xls")
End Sub
  

Creating a New Workbook

A better way to create a new workbook is to assign it to an object variable. In the following example, the Workbook object returned by the Add method is assigned to an object variable, newBook. Next, several properties of newBook are set. You can easily control the new workbook using the object variable.

Sub AddNew()
Set NewBook = Workbooks.Add
    With NewBook
        .Title = "All Sales"
        .Subject = "Sales"
        .SaveAs Filename:="Allsales.xls"
    End With
End Sub
  

Tab Property

Microsoft Excel determines if the worksheet's first tab color index is set to none and notifies the user.

Sub CheckTab()

    ' Determine if color index of 1st tab is set to none.
    If Worksheets(1).Tab.ColorIndex = xlColorIndexNone Then
        MsgBox "The color index is set to none for the 1st " & _
            "worksheet tab."
    Else
        MsgBox "The color index for the tab of the 1st worksheet " & _
            "is not set none."
    End If

End Sub
  

ThisCell Property

A function called "UseThisCell" contains the ThisCell property to notify the user of the cell address.

Function UseThisCell()

    MsgBox "The cell address is: " & _
        Application.ThisCell.Address

End Function

DeleteDuplicateRows

This macro will delete duplicate rows in a range.  To use, select a single-column range of cells, comprising the range of rows from which duplicates are to be deleted, e.g., C2:C99.   To determine whether a row has duplicates, the values in the selected column are compared. Entire rows are not compared against one another.  Only the selected column is used for comparison.  When duplicate values are found in the active column, the first row remains, and all subsequent rows are deleted.
Public Sub DeleteDuplicateRows()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DeleteDuplicateRows
' This will delete duplicate records, based on the Active Column. That is,
' if the same value is found more than once in the Active Column, all but
' the first (lowest row number) will be deleted.
'
' To run the macro, select the entire column you wish to scan for
' duplicates, and run this procedure.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim R As Long
Dim N As Long
Dim V As Variant
Dim Rng As Range

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Set Rng = Application.Intersect(ActiveSheet.UsedRange, _
                    ActiveSheet.Columns(ActiveCell.Column))

Application.StatusBar = "Processing Row: " & Format(Rng.Row, "#,##0")

N = 0
For R = Rng.Rows.Count To 2 Step -1
If R Mod 500 = 0 Then
    Application.StatusBar = "Processing Row: " & Format(R, "#,##0")
End If

V = Rng.Cells(R, 1).Value
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Note that COUNTIF works oddly with a Variant that is equal to vbNullString.
' Rather than pass in the variant, you need to pass in vbNullString explicitly.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If V = vbNullString Then
    If Application.WorksheetFunction.CountIf(Rng.Columns(1), vbNullString) > 1 Then
        Rng.Rows(R).EntireRow.Delete
        N = N + 1
    End If
Else
    If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
        Rng.Rows(R).EntireRow.Delete
        N = N + 1
    End If
End If
Next R

EndMacro:

Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate Rows Deleted: " & CStr(N)

End Sub

DeleteRowOnCell

The macro DeleteBlankRows will delete a row if the entire row is blank.  This macro will delete the entire row if a the cell in the specified column is blank.  Only this column is checked. Other columns are ignored.

Public Sub DeleteRowOnCell()

On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveSheet.UsedRange

End Sub

To use this macro, select a columnar range of cells, and then run the macro.    If the cell in that column is blank, the entire row will be deleted.  To process the entire column, click the column header to select the entire column.

Delete Blank Rows

The DeleteBlankRows procedure shown below will delete all blank rows in the worksheet specified by the WorksheetName parameter. If this parameter is omitted, the active sheet is used. The procedure will delete rows that are entirely blank or contain cells that have only a single apostrophe (text formatting control character).  The procedure requires the IsRowClear function, shown after the DeleteBlankRows procedure. It will not delete rows that contain formulas, even if that formula returns an empty value. The function will not delete rows that are precedents of a formula in a cell if those precedent rows have lower row number than the row.  For example, if rows 1 to 5 are completely blank, and a formula in A10 references rows 1 to 5, rows 1 to 5 will not be deleted.  However, if a formula refers to a range in higher numbered rows than the cell containing the formula, and those rows are entirely blank, those rows referenced by the formula will be deleted. Therefore, the reference of the formula may be changed as rows above the formula are deleted.

Sub DeleteBlankRows(Optional WorksheetName As Variant)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DeleteBlankRows
' This function will delete all blank rows on the worksheet
' named by WorksheetName. This will delete rows that are
' completely blank (every cell = vbNullString) or that have
' cells that contain only an apostrophe (special Text control
' character).
' The code will look at each cell that contains a formula,
' then look at the precedents of that formula, and will not
' delete rows that are a precedent to a formula. This will
' prevent deleting precedents of a formula where those
' precedents are in lower numbered rows than the formula
' (e.g., formula in A10 references A1:A5). If a formula
' references cell that are below (higher row number) the
' last used row (e.g, formula in A10 reference A20:A30 and
' last used row is A15), the refences in the formula will
' be changed due to the deletion of rows above the formula.
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim RefColl As Collection
Dim RowNum As Long
Dim Prec As Range
Dim Rng As Range
Dim DeleteRange As Range
Dim LastRow As Long
Dim FormulaCells As Range
Dim Test As Long
Dim WS As Worksheet
Dim PrecCell As Range

If IsMissing(WorksheetName) = True Then
    Set WS = ActiveSheet
Else
    On Error Resume Next
    Set WS = ActiveWorkbook.Worksheets(WorksheetName)
    If Err.Number <> 0 Then
        '''''''''''''''''''''''''''''''
        ' Invalid worksheet name.
        '''''''''''''''''''''''''''''''
        Exit Sub
    End If
End If
   

If Application.WorksheetFunction.CountA(WS.UsedRange.Cells) = 0 Then
    ''''''''''''''''''''''''''''''
    ' Worksheet is blank. Get Out.
    ''''''''''''''''''''''''''''''
    Exit Sub
End If

''''''''''''''''''''''''''''''''''''''
' Find the last used cell on the
' worksheet.
''''''''''''''''''''''''''''''''''''''
Set Rng = WS.Cells.Find(what:="*", after:=WS.Cells(WS.Rows.Count, WS.Columns.Count), lookat:=xlPart, _
    searchorder:=xlByColumns, searchdirection:=xlPrevious, MatchCase:=False)

LastRow = Rng.Row

Set RefColl = New Collection

'''''''''''''''''''''''''''''''''''''
' We go from bottom to top to keep
' the references intact, preventing
' #REF errors.
'''''''''''''''''''''''''''''''''''''
For RowNum = LastRow To 1 Step -1
    Set FormulaCells = Nothing
    If Application.WorksheetFunction.CountA(WS.Rows(RowNum)) = 0 Then
        ''''''''''''''''''''''''''''''''''''
        ' There are no non-blank cells in
        ' row R. See if R is in the RefColl
        ' reference Collection. If not,
        ' add row R to the DeleteRange.
        ''''''''''''''''''''''''''''''''''''
        On Error Resume Next
        Test = RefColl(CStr(RowNum))
        If Err.Number <> 0 Then
            ''''''''''''''''''''''''''
            ' R is not in the RefColl
            ' collection. Add it to
            ' the DeleteRange variable.
            ''''''''''''''''''''''''''
            If DeleteRange Is Nothing Then
                Set DeleteRange = WS.Rows(RowNum)
            Else
                Set DeleteRange = Application.Union(DeleteRange, WS.Rows(RowNum))
            End If
        Else
            ''''''''''''''''''''''''''
            ' R is in the collection.
            ' Do nothing.
            ''''''''''''''''''''''''''
        End If
        On Error GoTo 0
        Err.Clear
    Else
        '''''''''''''''''''''''''''''''''''''
        ' CountA > 0. Find the cells
        ' containing formula, and for
        ' each cell with a formula, find
        ' its precedents. Add the row number
        ' of each precedent to the RefColl
        ' collection.
        '''''''''''''''''''''''''''''''''''''
        If IsRowClear(RowNum:=RowNum) = True Then
            '''''''''''''''''''''''''''''''''
            ' Row contains nothing but blank
            ' cells or cells with only an
            ' apostrophe. Cells that contain
            ' only an apostrophe are counted
            ' by CountA, so we use IsRowClear
            ' to test for only apostrophes.
            ' Test if this row is in the
            ' RefColl collection. If it is
            ' not in the collection, add it
            ' to the DeleteRange.
            '''''''''''''''''''''''''''''''''
            On Error Resume Next
            Test = RefColl(CStr(RowNum))
            If Err.Number = 0 Then
                ''''''''''''''''''''''''''''''''''''''
                ' Row exists in RefColl. That means
                ' a formula is referencing this row.
                ' Do not delete the row.
                ''''''''''''''''''''''''''''''''''''''
            Else
                If DeleteRange Is Nothing Then
                    Set DeleteRange = WS.Rows(RowNum)
                Else
                    Set DeleteRange = Application.Union(DeleteRange, WS.Rows(RowNum))
                End If
            End If
        Else
            On Error Resume Next
            Set FormulaCells = Nothing
            Set FormulaCells = WS.Rows(RowNum).SpecialCells(xlCellTypeFormulas)
            On Error GoTo 0
            If FormulaCells Is Nothing Then
                '''''''''''''''''''''''''
                ' No formulas found. Do
                ' nothing.
                '''''''''''''''''''''''''
            Else
                '''''''''''''''''''''''''''''''''''''''''''''''''''
                ' Formulas found. Loop through the formula
                ' cells, and for each cell, find its precedents
                ' and add the row number of each precedent cell
                ' to the RefColl collection.
                '''''''''''''''''''''''''''''''''''''''''''''''''''
                On Error Resume Next
                For Each Rng In FormulaCells.Cells
                    For Each Prec In Rng.Precedents.Cells
                        RefColl.Add Item:=Prec.Row, key:=CStr(Prec.Row)
                    Next Prec
                Next Rng
                On Error GoTo 0
            End If
        End If
       
    End If
   
    '''''''''''''''''''''''''
    ' Go to the next row,
    ' moving upwards.
    '''''''''''''''''''''''''
Next RowNum


''''''''''''''''''''''''''''''''''''''''''
' If we have rows to delete, delete them.
''''''''''''''''''''''''''''''''''''''''''

If Not DeleteRange Is Nothing Then
    DeleteRange.EntireRow.Delete shift:=xlShiftUp
End If

End Sub

Function IsRowClear(RowNum As Long) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''
' IsRowClear
' This procedure returns True if all the cells
' in the row specified by RowNum as empty or
' contains only a "'" character. It returns False
' if the row contains only data or formulas.
''''''''''''''''''''''''''''''''''''''''''''''''''
Dim ColNdx As Long
Dim Rng As Range
ColNdx = 1
Set Rng = Cells(RowNum, ColNdx)
Do Until ColNdx = Columns.Count
    If (Rng.HasFormula = True) Or (Rng.Value <> vbNullString) Then
        IsRowClear = False
        Exit Function
    End If
    Set Rng = Cells(RowNum, ColNdx).End(xlToRight)
    ColNdx = Rng.Column
Loop

IsRowClear = True

End Function

Flipping Or Mirroring A Range

This macro will reverse the order of a range of data.  You may flip data in a single row or in a single column of data (i.e., an N by 1 array or an 1 by N array).   You may not select and entire row or an entire column.

Public Sub FlipSelection()

Dim Arr() As Variant
Dim Rng As Range
Dim C As Range
Dim Rw As Long
Dim Cl As Long

On Error GoTo EndMacro

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Set Rng = Selection
Rw = Selection.Rows.Count
Cl = Selection.Columns.Count
If Rw > 1 And Cl > 1 Then
   MsgBox "Selection May Include Only 1 Row or 1 Column", _
    vbExclamation, "Flip Selection"
Exit Sub
End If

If Rng.Cells.Count = ActiveCell.EntireRow.Cells.Count Then
    MsgBox "You May Not Select An Entire Row", vbExclamation, _
        "Flip Selection"
    Exit Sub
End If
If Rng.Cells.Count = ActiveCell.EntireColumn.Cells.Count Then
    MsgBox "You May Not Select An Entire Column", vbExclamation, _
        "Flip Selection"
    Exit Sub
End If

If Rw > 1 Then
    ReDim Arr(Rw)
Else
    ReDim Arr(Cl)
End If

Rw = 0
For Each C In Rng
    Arr(Rw) = C.Formula
    Rw = Rw + 1
Next C

Rw = Rw - 1
For Each C In Rng
    C.Formula = Arr(Rw)
    Rw = Rw - 1
Next C

EndMacro:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

End Sub

Getting A Built-In Or Custom Document Property

This macro will return the value of a custom or built-in document property.  If the property does not exist, and empty string is returned.

Public Function GetProperty(p As String)
Dim S As Variant

On Error Resume Next

S = ActiveWorkbook.CustomDocumentProperties(p)
If S <> "" Then
    GetProperty = S
    Exit Function
End If

On Error GoTo EndMacro
GetProperty = ActiveWorkbook.BuiltinDocumentProperties(p)
Exit Function

EndMacro:
GetProperty = ""

End Function

Headers And Footers

From the Page Setup dialog, you can set up some basic headers and footers, but you're somewhat limited.  With VBA, however, you can create your own custom headers and footers:

Activesheet.Pagesetup.Leftfooter = "Some Text"

In addition to Leftfooter, you can use CenterFooter, RightFooter, LeftHeader, CenterHeader,or RightHeader.

To include one of the built-in document properties in a footer (or header), use

Activesheet.Pagesetup.Leftfooter =     ActiveWorkbook.Builtinproperties("Manager")

Of course, change "Manager" to the name of the property you want to include.

Highlighting The Active Cell

If you want to make the active cell appear in a special color, use the following code in the Workbook_SheetSelectionChange event of the workbook.

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object,
    ByVal Target As Excel.Range)
Static OldRange As Range
On Error Resume Next
Target.Interior.ColorIndex = 6 ' yellow - change as needed
OldRange.Interior.ColorIndex = xlColorIndexNone
Set OldRange = Target

End Sub

Playing WAV Files From VBA

It is very simple to have your macro code play a WAV file.  First, add a Windows95 API declaration at the top of your code module:

Declare Function sndPlaySound32 Lib "winmm.dll" Alias _
    "sndPlaySoundA" (ByVal lpszSoundName As String, _
    ByVal uFlags As Long) As Long

Then, call the function, passing it the name of the WAV file you want to play:

Call sndPlaySound32("c:\test\MySound.WAV", 0)

Printing Comments To Word

This macro will print all of the cell comments to Microsoft Word.  The Word application will remain
open and active.  You may then save or print the cell comment document.    Make sure that
you have enabled references to Word objects, from the Tools->References menu.

Public Sub PrintCellComments()

Dim Cmt As String
Dim C As Range
Dim I As Integer
Dim WordObj As Object
Dim ws As Worksheet
Dim PrintValue As Boolean
Dim res As Integer
On Error Resume Next
Err.Number = 0

res = MsgBox("Do want to print cell values with comments?", _
    vbYesNoCancel + vbQuestion, "Print Cell Comments")
Select Case res
    Case vbCancel
        Exit Sub
    Case vbYes
        PrintValue = True
    Case Else
        PrintValue = False
End Select

Set WordObj = GetObject(, "Word.Application")
If Err.Number = 429 Then
    Set WordObj = CreateObject("Word.Application")
    Err.Number = 0
End If

WordObj.Visible = True
WordObj.Documents.Add
With WordObj.Selection
.TypeText Text:="Cell Comments In Workbook: " + ActiveWorkbook.Name
.TypeParagraph
.TypeText Text:="Date: " + Format(Now(), "dd-mmm-yy hh:mm")
.TypeParagraph
.TypeParagraph
End With

For Each ws In Worksheets
    For I = 1 To ws.Comments.Count
        Set C = ws.Comments(I).Parent
        Cmt = ws.Comments(I).Text
        With WordObj.Selection
        .TypeText Text:="Comment In Cell: " + _
            C.Address(False, False, xlA1) + " on sheet: " + ws.Name
        If PrintValue = True Then
            .TypeText Text:=" Cell Value: " + Format(C.Value)
        End If
        .TypeParagraph
        .TypeText Text:=Cmt
        .TypeParagraph
        .TypeParagraph
        End With
    Next I
Next ws

Set WordObj = Nothing
MsgBox "Finished Printing Comments To Word", vbInformation, _
    "PrintCellComments"

End Sub

Printing Formulas To Word

This macro will print all of the cell values and formulas to Microsoft Word.  The Word application will
remain open and active.  You may then save or print the document.  Make sure that
you have enabled references to Word objects, from the Tools->References menu.

Public Sub PrintFormulasToWord()

Dim Cnt As String
Dim C As Range

Dim WordObj As word.Application
Dim HasArr As Boolean

On Error Resume Next
Err.Number = 0

Set WordObj = GetObject(, "Word.Application")
If Err.Number = 429 Then
    Set WordObj = CreateObject("Word.Application")
    Err.Number = 0
End If

WordObj.Visible = True
WordObj.Documents.Add

With WordObj.Selection
    .Font.Name = "Courier New"
    .TypeText "Formulas In Worksheet: " + ActiveSheet.Name   
    .TypeParagraph
    .TypeText "Cells: " + Selection.Cells(1,1).Address(False,False,xlA1) _             & " to " & Selection.Cells(Selection.Rows.Count,  _
            Selection.Columns.Count).Address(False, False, xlA1)
    .TypeParagraph
    .TypeParagraph
End With

For Each C In Selection
    HasArr = C.HasArray
    Cnt = C.Formula
    If HasArr Then
        Cnt = "{" + Cnt + "}"
    End If
    If Cnt <> "" Then
        With WordObj.Selection
            .Font.Bold = True
            .TypeText C.Address(False, False, xlA1) & ": "
            .Font.Bold = False
            .TypeText Cnt
            .TypeParagraph
            .TypeParagraph
        End With
    End If
Next C
MsgBox "Done printing formulas to Word. ", , "Print Formulas To Word"

End Sub

Saving And Returning To A Location

These three macros are used to save a location and then return to that location later.   It is
useful when you need to change the Selection range during the execution of a macro, and then
return to the original Selection range when your macro is complete.

Public Sub SaveLocation(ReturnToLoc As Boolean)

Static WB As Workbook
Static WS As Worksheet
Static R As Range

If ReturnToLoc = False Then
    Set WB = ActiveWorkbook
    Set WS = ActiveSheet
    Set R = Selection
Else
    WB.Activate
    WS.Activate
    R.Select
End If

End Sub

To save the current location, call SetSaveLoc.

Public Sub SetSaveLoc()
    SaveLocation (False)
End Sub

To return to the saved location, call GetSaveLoc.

Public Sub GetSaveLoc()
    SaveLocation (True)
End Sub

Saving All Workbooks

This macro will save all of the workbooks open in Excel.

Public Sub SaveAll()

Dim WB As Workbook
For Each WB In Workbooks
    WB.Save
Next WB
Application.StatusBar = "All Workbooks Saved."

End Sub

Selecting The Current Array

If the ActiveCell is part of an array, this macro will select the entire array.

Public Sub SelectArray()

Dim Msg As String

On Error GoTo EndOfMacro
Msg = "Cell is not part of an array."

ActiveCell.CurrentArray.Select
Msg = "Array Selected."


EndOfMacro:
Application.StatusBar = Msg

End Sub

Selecting The Current Named Range

If the ActiveCell is part of a named range, this macro will select the entire named range.
This macro requires the CellInNamedRange function, shown first.

CellInNamedRange

Public Function CellInNamedRange(Rng As Range) As String

Dim N As Name
Dim C As Range
Dim TestRng As Range
On Error Resume Next

For Each N In ActiveWorkbook.Names
    Set C = Nothing
    Set TestRng = N.RefersToRange
    Set C = Application.Intersect(TestRng, Rng)
    If Not C Is Nothing Then
        CellInNamedRange = N.Name
        Exit Function
    End If
Next N
CellInNamedRange = ""

End Function

SelectRange

Public Sub SelectRange()

Dim RngName As String
Dim R As Range
Set R = ActiveCell
Dim Msg As String

Msg = "Active Cell Is Not In A Named Range."
RngName = CellInNamedRange(R)
If RngName <> "" Then
    Range(RngName).Select
    Msg = "Range: " + RngName + " Selected."
End If

Application.StatusBar = Msg

End Sub

CellIn Named Range

Public Function CellInNamedRange(Rng As Range) As String

Dim N As Name
Dim C As Range
Dim TestRng As Range
On Error Resume Next

For Each N In ActiveWorkbook.Names
    Set C = Nothing
    Set TestRng = N.RefersToRange
    Set C = Application.Intersect(TestRng, Rng)
    If Not C Is Nothing Then
        CellInNamedRange = N.Name
        Exit Function
    End If
Next N
CellInNamedRange = ""

End Function

SelectRange

Public Sub SelectRange()

Dim RngName As String
Dim R As Range
Set R = ActiveCell
Dim Msg As String

Msg = "Active Cell Is Not In A Named Range."
RngName = CellInNamedRange(R)
If RngName <> "" Then
    Range(RngName).Select
    Msg = "Range: " + RngName + " Selected."
End If

Application.StatusBar = Msg

End Sub

Sheet Names

It is very simple to retrieve sheet names in VBA.  They are stored in two collection objects in the ActiveWorkbook object: the Sheets collection and the Worksheets collection.  The Sheets collection contains both worksheets and chart sheets.   The Worksheets collection contains only worksheets.

To retrieve the name of the first sheet in the workbook, use

Public Function FirstSheetName()
    FirstSheetName = Sheets(1).Name
End Function

To retrieve the name of the last sheet in the workbook, use

Public Function LastSheetName()
    LastSheetName = Sheets(Sheets.Count).Name
End Function

You can return an array of all the sheet names with the following

Public Function AllSheetNames()
    Dim Arr() As String
    Dim I as Integer
    Redim Arr(Sheets.Count-1)
    For I = 0 To Sheets.Count - 1
        Arr(i) = Sheets(I+1).Name
    Next I
    AllSheetNames = Arr      ' return a row array OR
    AllSheetNames = Application.Worksheetfunction.Transpose(Arr)
                             ' return a column array
End Function

Closing All Inactive Workbooks

This macro will close all of the workbooks, except the active workbook, which will remain open active.

Public Sub CloseAllInactive()

Dim Wb As Workbook
Dim AWb As String
AWb = ActiveWorkbook.Name

SaveAll
For Each Wb In Workbooks
    If Wb.Name <> AWb Then
        Wb.Close savechanges:=True
    End If
Next Wb
Application.StatusBar = "All Workbooks Closed."

End Sub

Closing All Workbooks

This macro will close all of the workbooks open in Excel. 

Public Sub CloseAll()

Dim Wb As Workbook
SaveAll
For Each Wb In Workbooks
    If Wb.Name <> ThisWorkbook.Name Then
        Wb.Close savechanges:=True
    End If
Next Wb
ThisWorkbook.Close savechanges:=True

End Sub

Macro Compare two lists and delete duplicate items

The following sample macro compares one (master) list against another list, and deletes duplicate items in the second list that are also in the master list. The first list is on Sheet1 in the range A1:A10. The second list is on Sheet2 in the range A1:A100. To use the macro, select either sheet, and then run the macro.

Sub DelDups_TwoLists()
Dim iListCount As Integer
Dim iCtr As Integer

' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False

' Get count of records to search through (list that will be deleted).
iListCount = Sheets("sheet2").Range("A1:A100").Rows.Count

' Loop through the "master" list.
For Each x In Sheets("Sheet1").Range("A1:A10")
   ' Loop through all records in the second list.
   For iCtr = 1 To iListCount
      ' Do comparison of next record.
      ' To specify a different column, change 1 to the column number.
      If x.Value = Sheets("Sheet2").Cells(iCtr, 1).Value Then
         ' If match is true then delete row.
         Sheets("Sheet2").Cells(iCtr, 1).Delete xlShiftUp
         ' Increment counter to account for deleted row.
         iCtr = iCtr + 1
      End If
   Next iCtr
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub

Delete duplicate items in a single list

The following sample macro searches a single list in the range A1:A100 and deletes all duplicate items in the list. This macro requires that you do not have empty cells in the list range. If your list does contain empty cells, sort the data in ascending order so that the empty cells are all at the end of your list.

Sub DelDups_OneList()
Dim iListCount As Integer
Dim iCtr As Integer

' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False

' Get count of records to search through.
iListCount = Sheets("Sheet1").Range("A1:A100").Rows.Count
Sheets("Sheet1").Range("A1").Select
' Loop until end of records.
Do Until ActiveCell = ""
   ' Loop through records.
   For iCtr = 1 To iListCount
      ' Don't compare against yourself.
      ' To specify a different column, change 1 to the column number.
      If ActiveCell.Row <> Sheets("Sheet1").Cells(iCtr, 1).Row Then
         ' Do comparison of next record.
         If ActiveCell.Value = Sheets("Sheet1").Cells(iCtr, 1).Value Then
            ' If match is true then delete row.
            Sheets("Sheet1").Cells(iCtr, 1).Delete xlShiftUp
               ' Increment counter to account for deleted row.
               iCtr = iCtr + 1
         End If
      End If
   Next iCtr
   ' Go to next record.
   ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub

Macro to Change All Text in a Cell Range to Initial Capital Letters

Sub Proper_Case()
   ' Loop to cycle through each cell in the specified range.
   For Each x In Range("C1:C5")
      ' There is not a Proper function in Visual Basic for Applications.
      ' So, you must use the worksheet function in the following form:
      x.Value = Application.Proper(x.Value)
   Next
End Sub

Macro to Change All Text in a Range to Lowercase Letters

Sub Lowercase()
   ' Loop to cycle through each cell in the specified range.
   For Each x In Range("B1:B5")
      x.Value = LCase(x.Value)
   Next
End Sub

Macro to Change All Text in a Range to Uppercase Letters

Sub Uppercase()
   ' Loop to cycle through each cell in the specified range.
   For Each x In Range("A1:A5")
      ' Change the text in the range to uppercase letters.
      x.Value = UCase(x.value)
   Next
End Sub

Counting Rows & Columns & Sheets

When you have selected a range, it is sometimes useful to know how many rows or columns you have selected as this information can be used in your macros (for eg when you have reached the end, you will know it is time to stop the macros. This macro will do the trick.

Sub Count()
myCount = Selection.Rows.Count    'Change Rows to Columns to count columns
MsgBox myCount
End Sub

The next macro counts the number of sheets instead. Refer to Protecting all sheets macro which uses this method.

Sub Count2()
myCount = Application.Sheets.Count
MsgBox myCount
End Sub

Auto Run

Making your macros run automatically when opening your workbook. You can either use the Auto Open method or the Workbook Open method. These macros will display the message "Hello" when you open the workbook.

Sub Auto_Open()
Msgbox "Hello"
End Sub

This code would be located in the module. However if you use the second method, the code must be in the workbook (double click "This Workbook" in the explorer window). Click on the drop down list (that says General) and select Workbook. Click on the drop down list (that says declarations) and select Open.

Private Sub Workbook_Open()
Msgbox "Hello"
End Sub

Create New Excel Worksheet With VBA

The Excel VBA macro below will create a new Excel Worksheet called ‘RawData’ or we can use msgbox to ask for the Worksheet name if needed.

If there is already a Worksheet called RawData, user will be ask whether they want to use the old Worksheet and cancel new Worksheet creation, or delete the old Worksheet and continue creating a new blank Worksheet.

Sub CreateNewWorksheet()

    Dim oSheet As Worksheet, vRet As Variant

    On Error GoTo errHandler

    'creating a new excel worksheet called RawData
    Set oSheet = Worksheets.Add
    With oSheet
        .Name = "RawData"
        .<a title="See also Number of Cells/Rows/Columns With Formula" href="http://office-2all.blogspot.in/">Cells</a>(1.1).Select
        .Activate
    End With
    Exit Sub

errHandler:

    'if error due to duplicate worksheet detected
    If Err.Number = 1004 Then
        'display an options to user
        vRet = MsgBox("Worksheet called 'RawData' is already exist, " & _
            "click yes to continue creating new Worksheet and delete the old one, " & _
            "or click no to go to the old worksheet.", _
            vbOKCancel, "Duplicate Worksheet")

        If vRet = vbOK Then
            'delete the old worksheet
            Application.DisplayAlerts = False
            Worksheets("RawData").Delete
            Application.DisplayAlerts = True

            'rename and activate the new worksheet
            With oSheet
                .Name = "RawData"
                .Cells(1.1).Select
                .Activate
            End With
        Else
            'cancel the operation, delete the new worksheet
            Application.DisplayAlerts = False
            oSheet.Delete
            Application.DisplayAlerts = True
            'activate the old worksheet
            Worksheets("RawData").Activate
        End If

    End If

End Sub

Auto Format Excel Cells with Error Value

With the simple Excel macro below, we can make all cells in active Worksheet that contains Error value in it, like #NULL, #Div/0!, #VALUE!, #Ref, #NAME?, #NUM!, And #N/A, will automatically having cell format that different/stand out among all other cells.

In this example, background color of the cell that contains the error value will automatically change color to red, each time the Excel Worksheet activated.

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim errCells As Range

Set errCells = Cells.SpecialCells(xlCellTypeFormulas, xlErrors)
errCells.Interior.Color = 255

Set errCells = Nothing
End Sub


Note that using the Cells.SpeciallCells function, we do not need to perform any looping to get Cells which contains the Error value.

This is just like automating Excel cell conditional formating process. Instead of selecting manually all the cells contains Error value or select all cells and then performing cell conditional format, with above code, we do it automatically using simple Excel VBA macro.

Finding Cell with Minimum/Maximum Value in Active Worksheet

Let say we want to find position of cell containing the minimum/maximum value in current/active Excel worksheet, and then after we found the cell, we will change the cell format to make it stand out before other cells.

The logic is simple, we just need to use Excel MIN function to find the minimum/maximum value on the worksheet, and then using Excel FIND function we will find which cell contain that minimum/ maximum value.

Excel VBA macro implementation of the algorithm above will look like below, change code Application.Min(oRg) into Application.Max(oRg) to find the maximum value instead of minimum value.

Sub FindMinValue()

    Dim oRg As Range, iMin As Variant

    Set oRg = Cells
    'Finding the minimum value
    'change Application.Min(oRg) into Application.Max(oRg) to find the maximum value
    iMin = Application.Min(oRg)

    'Select cell containing the min value
    oRg.Find(What:=iMin, _
        After:=oRg.Range("A1"), _
        LookIn:=xlValues, _
        LookAt:=xlPart, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False _
        ).Select

    'Change selected cell format
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

    'Displaying min value info
    With Selection
        MsgBox "Min value : " & iMin & vbCrLf & _
        "Cell position " & vbCrLf & _
        "Row : " & .Row & vbCrLf & _
        "Column : " & .Column
    End With

End Sub