Visual Basic for Applications/Worksheet Common Utilities

Summary

The procedures on this page are made for Microsoft Excel, and include commonly used worksheet utilities.

The VBA Code

Does Worksheet Exist?

Before making a worksheet or referring to one that is assumed to exist, it is best to be certain one way or the the other. This routine returns True if there is already a worksheet with the parameter's name.

Sub testSheetExists()
    'run to test existence of a worksheet
    
    If SheetExists("Sheet1") Then
        MsgBox "Exists"
    Else: MsgBox "Does not exist"
    End If

End Sub

Function SheetExists(ByVal sSheetName As String) As Boolean
    'Return true if sheet already exists
    
    On Error Resume Next
        'exists if its name is not the null string
        SheetExists = (Sheets(sSheetName).Name <> vbNullString)
    On Error GoTo 0

End Function

Add a Named Worksheet

This routine adds a worksheet with a specified name. First make sure however that the worksheet name is not in use; see SheetExists().

Sub testAddWorksheet()

    AddWorksheet ("Sheet1")

End Sub

Function AddWorksheet(ByVal sName As String) As Boolean
    'adds a Worksheet to ThisWorkbook with name sName

    With ThisWorkbook
        .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = sName
    End With

    AddWorksheet = True

End Function

Changing Column References

At times it is useful to have routines to change the column alpha reference style to a numerical one, and vice versa. These procedures to that.

Sub testCellRefConversion()
    'run this to test cell reference conversions
     
    Dim nNum As Long, sLet As String
    
    'set input values here
    nNum = 839
    sLet = "AFG"
    
    MsgBox ConvColAlphaToNum(sLet)

    MsgBox ConvColNumToAlpha(nNum)

End Sub

Function ConvColAlphaToNum(ByVal sColAlpha As String) As Long
    'Converts an Excel column reference from alpha to numeric
    'For example, "A" to 1, "AFG" to 839 etc

    Dim nColNum As Long
    
    'get the column number
    nColNum = Range(sColAlpha & 1).Column
   
    'output to function
    ConvColAlphaToNum = nColNum
    
End Function

Function ConvColNumToAlpha(ByVal nColNum As Long) As String
    'Converts an Excel column reference from numeric to alpha
    'For example, 1 to "A", 839 to "AFG" etc

    Dim sColAlpha As String, vA As Variant
    
    'get the column alpha, in form $D$14
    sColAlpha = Cells(1, nColNum).Address
    
    'split the alpha reference on $
    vA = Split(sColAlpha, "$")
      
    'output second element (1) of array to function
    ConvColNumToAlpha = vA(1) 'array is zero based
  
End Function

Next Free Row or Column

These procedures find the next free column or row. One set selects the cell in question while the other set simply return its position. Examples exist for both columns and rows, and in the absence of a chosen parameter, column 1 or row 1 is assumed.

Sub testFindingNextCells()
    'run this to test next-cell utilities
    'Needs a few cols and rows of data in sheet1

    'deselect to test
    SelectNextAvailCellinCol 1
    'MsgBox RowNumNextAvailCellinCol(1)
    'SelectNextAvailCellinRow 6
    'MsgBox ColNumNextAvailCellinRow(1)

End Sub

Function SelectNextAvailCellinCol(Optional ByVal nCol as Long = 1) As Boolean
    'Selects next available blank cell
    'in column nCol, when approached from sheet end
        
    Cells(Rows.Count, nCol).End(xlUp).Offset(1, 0).Select

End Function

Function RowNumNextAvailCellinCol(Optional ByVal nCol As Long = 1) As Long
    'Returns next available blank cell's row number
    'in column nCol, when approached from sheet end
    
    RowNumNextAvailCellinCol = Cells(Rows.Count, nCol).End(xlUp).Offset(1, 0).Row

End Function

Function SelectNextAvailCellinRow(Optional ByVal nRow as Long = 1) As Boolean
    'Selects next available blank cell
    'in row nRow, when approached from sheet right
        
    Cells(nRow, Columns.Count).End(xlToLeft).Offset(0, 1).Select

End Function

Function ColNumNextAvailCellinRow(Optional ByVal nRow As Long = 1) As Long
    'Returns next available blank cell column number
    'in row nRow, when approached from sheet right
    
    ColNumNextAvailCellinRow = Cells(nRow, Columns.Count).End(xlToLeft).Offset(0, 1).Column

End Function

Clear Worksheet Cells

This procedure makes a selective clear of the specified worksheet, depending on the parameter nOpt. The options as coded include, clear contents, (that is the text), clear formats, (the fonts and colours), and clear all, a combination of the two.

Sub testClearWorksheet()
    'run this to test worksheet clearing
    
    If SheetExists("Sheet1") Then
        ClearWorksheet "Sheet11", 3
    Else 'do other stuff
    End If

End Sub

Function ClearWorksheet(ByVal sSheet As String, ByVal nOpt As Integer) As Boolean
   'clears worksheet contents, formats, or both
   'nOpt options: contents=1, formats=2, all=3
      
   Dim oWSht As Worksheet
   Set oWSht = ThisWorkbook.Worksheets(sSheet)
   oWSht.Activate
      
   With oWSht.Cells
    Select Case nOpt
        Case 1 'contents only
            .ClearContents
        Case 2 'formats only
            .ClearFormats
        Case 3 'formats and contents
            .Clear
    Case Else
        MsgBox "Illegal option in ClearWorksheet - closing"
        Exit Function
    End Select
   End With
   oWSht.Cells(1, 1).Select
   
   ClearWorksheet = True

End Function

Sub testClearRange()
    'place some text in cell 1,1 of sheet1
    
    Dim oSht As Worksheet, Rng As Range

    Set oSht = ThisWorkbook.Worksheets("Sheet1")
    
    Set Rng = oSht.Cells(1, 1)
    
    ClearRange Rng, "all"
    Rng.Select
    
    Set Rng = Nothing

End Sub

Sub ClearRange(ByRef rRng As Range, Optional ByVal sOpt As String = "contents")
   'clears cell range contents, formats, or both
   'sOpt options: "contents", "formats", or "all"
   'sOpt is optional, default "contents".
   
   With rRng
    Select Case LCase(sOpt)
        Case "contents"  'contents only
            .ClearContents
        Case "formats"   'formats only
            .ClearFormats
        Case "all"       'formats and contents
            .Clear
    Case Else
        MsgBox "Illegal option in ClearRange - closing"
        Exit Sub
    End Select
   End With
      
End Sub

Move Rows and Columns

At times it is useful to shift entire columns and rows of data by one place on the spreadsheet, and in any case the process can be repeated as often as is necessary. These procedures assume that the user has first placed the cursor in the column or row of interest. The columns feature is of particular use when bringing an external tabulation into the worksheet; the columns will almost certainly need to be rearranged to match those of the resident set. Food databases are notorious for their different formats, none matching the sequence of those on food labels. Hopefully, some day a product's food data could be entered all at once with a scanned image.

Sub MoveRowDown()
    'moves entire row with cursor down by one place
    'works by moving next row up by one place
    'includes all formats    
    
    Range(ActiveCell.Row + 1 & ":" & ActiveCell.Row + 1).Cut
    ActiveCell.EntireRow.Insert xlShiftDown
    ActiveCell.Offset(1, 0).Select
    
End Sub

Sub MoveRowUp()
    'moves entire row with cursor up by one place
    'includes all formats
    
    If ActiveCell.Row > 1 Then
        Range(ActiveCell.Row & ":" & ActiveCell.Row).Cut
        ActiveCell.Offset(-1, 0).Select
        ActiveCell.EntireRow.Insert xlShiftDown
    Else
        MsgBox "Already at top"
    End If
    
End Sub

Sub MoveColLeft()
    'moves entire column with cursor left one place
    'includes all formats
        
        Dim sColAlpha As String, vA As Variant
        Dim sCol As String
    
        If ActiveCell.Column > 1 Then
            'get the alpha reference for the column
            sColAlpha = Cells(1, ActiveCell.Column).Address
            vA = Split(sColAlpha, "$")
            sCol = vA(1) 'array zero based
            
            'then do the cut and insert
            Range(sCol & ":" & sCol).Cut
            ActiveCell.Offset(0, -1).Select
            ActiveCell.EntireColumn.Insert Shift:=xlShiftToRight
        Else
            MsgBox "Already at extreme left"
        End If
    
End Sub

Sub MoveColRight()
    'moves entire column with cursor right one place
    'works by moving next column left one place
    'includes all formats
        
        Dim sColAlpha As String, vA As Variant
        Dim sCol As String
            
        'get the alpha reference for the next column right
        sColAlpha = Cells(1, ActiveCell.Column + 1).Address
        vA = Split(sColAlpha, "$")
        sCol = vA(1) 'array zero based
        
        'then do the cut and insert to left for next col
        Range(sCol & ":" & sCol).Cut
        ActiveCell.Select
        ActiveCell.EntireColumn.Insert Shift:=xlShiftToRight
        ActiveCell.Offset(0, 1).Select

End Sub

Delete Various Worksheet Items

These procedures allow deletion of worksheets, rows, and columns. Before deleting a worksheet, it should first be confirmed to exist.

Sub testDeleteItems()
    'run to test item deletion
    
    'MsgBox DeleteRow(6, "Sheet1")
    'MsgBox DeleteCol(3, "Sheet1")
    MsgBox DeleteSheet("Sheet4")
     
End Sub
 
Function DeleteSheet(ByVal nSht As String) As Boolean
    'Returns true if nSht deleted else false
    'Check first if sheet exists before running this
    'No confirmation dialog will be produced
    
    Application.DisplayAlerts = False 'avoids confirm box
        DeleteSheet = ThisWorkbook.Worksheets(nSht).Delete
    Application.DisplayAlerts = True

End Function

Function DeleteRow(ByVal nRow As Long, ByVal sSht As String) As Boolean
    'Returns true if nRow deleted else false
    'No confirmation dialog will be produced
    
    DeleteRow = ThisWorkbook.Worksheets(sSht).Rows(nRow).Delete

End Function

Function DeleteCol(ByVal nCol As Long, ByVal sSht As String) As Boolean
    'Returns true if nCol deleted else false
    'No confirmation dialog will be produced
    
    DeleteCol = ThisWorkbook.Worksheets(sSht).Columns(nCol).Delete

End Function

See Also

{bookcat}