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 Modifications to 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 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}