Friday, December 27, 2013

VBA - Determine if worksheet of a given name exists

The following function takes a worksheet name as input and returns True/False whether or not a worksheet of that name exists:


Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean

    On Error Resume Next
        WorksheetExists = (Sheets(WorksheetName).Name <> "")
    On Error GoTo 0

End Function

VBA - Removing Illegal characters for a sheet name

I'll often want a MACRO to name a worksheet based on user input. Users often enter characters that aren't allowed to be contained within a worksheet name though. The following lines strip all illegal characters out of a variable so it can be used as a worksheet name:


MyArray = Array("<", ">", "|", "/", "*", "\", "?", "[", "]", """")
    For X = LBound(MyArray) To UBound(MyArray)
        SheetName = Replace(SheetName, MyArray(X), "_", 1)
    Next X

VBA - Misc useful Excel MACROs

These are a collection of tools I use to help me with redundant tasks:


Sub ToolAppendWorksheets()
    'Define some vars
    Dim wb As Workbook, wb2 As Workbook
    Dim WS As Worksheet
    Dim vFile As Variant
    
    'Set source workbook/worksheet
    Set wb = ActiveWorkbook
    Set WS = ActiveSheet
    
    'Open the target workbook
    vFile = Application.GetOpenFilename("Excel-files,*", _
        1, "Select a file to append worksheets from", , False)
    'if the user didn't select a file, exit sub
    If TypeName(vFile) = "Boolean" Then Exit Sub
    Workbooks.Open vFile
    'Set targetworkbook
    Set wb2 = ActiveWorkbook
    
    For Each sh In wb2.Worksheets
        sh.Copy After:=wb.Sheets(wb.Sheets.Count)
    Next sh
    
    wb2.Close SaveChanges:=False
    
End Sub
Sub ToolRemoveDuplicates()
    'A macro to delete all rows that have a duplicate entry in a certain column
    'Easy user defined vars
    DupCol = Int(InputBox("Which column are we comparing for duplicate entries?"))
    CompareChars = 50
    StartingRow = Int(InputBox("Starting at which row?"))
    
    'Internal code
    lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
    
    For rwIndex = StartingRow To lastrow
            CurLastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
            For delIndex = CurLastRow To rwIndex + 1 Step -1
                If Left(Cells(rwIndex, DupCol), CompareChars) = Left(Cells(delIndex, DupCol), CompareChars) Then
                    Rows(delIndex).Delete
                End If
            Next delIndex
    Next rwIndex
End Sub
Sub ToolInsertXRows()
    RowsToInsert = InputBox("How many rows would you like to insert?")
    InsertPoint = InputBox("Which row would you like to insert them at?")
    
    For Point = 1 To RowsToInsert
        Cells(InsertPoint, 1).Offset(1).EntireRow.Insert
    Next Point
End Sub
Sub ToolJoinAndMerge()
    Dim outputText As String
    delim = " "
    On Error Resume Next
    For Each cell In Selection
    outputText = outputText & cell.value & delim
    Next cell
    'Removes the Trailing Delim
    If Right$(outputText, 1) = delim Then outputText = Left$(outputText, Len(outputText) - 1)
    With Selection
    .Clear
    .Cells(1).value = outputText
    .Merge
    .HorizontalAlignment = xlGeneral
    .VerticalAlignment = xlCenter
    .WrapText = True
    End With
    Selection.ClearFormats
End Sub
Sub ToolDeleteBlankRows()
    
    'Deletes the entire row within the selection if the ENTIRE row contains no data.
    
    'We use Long in case they have over 32,767 rows selected.
    
    Dim i As Long
    
        'We turn off calculation and screenupdating to speed up the macro.
    
        With Application
    
            .Calculation = xlCalculationManual
    
            .ScreenUpdating = False
    
        'We work backwards because we are deleting rows.
    
        For i = Selection.Rows.Count To 1 Step -1
    
            If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then
    
                Selection.Rows(i).EntireRow.Delete
    
            End If
    
        Next i
    
            .Calculation = xlCalculationAutomatic
    
            .ScreenUpdating = True
    
        End With
    
End Sub

VBA - Returning the column letter for a given header in the first row

Using a wrapper for the find function - I prefer to use a wrapper to simplify my syntax elsewhere in the program - we will be able to return the numerical value for the column that has the header text we are looking for. We then use a function to convert this numerical value to the desired letter range:

Public Function FindHeader(HeaderText As String, Optional ourRow As Integer = 1)
    
    FindHeader = Rows(ourRow).Find(What:=HeaderText, _
    LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, MatchCase:=False, _
    SearchFormat:=False).Column
End Function

Public Function ColumnLetter(ColumnNumber As Integer) As String
    Dim n As Integer
    Dim c As Byte
    Dim s As String

    n = ColumnNumber
    Do
        c = ((n - 1) Mod 26)
        s = Chr(c + 65) & s
        n = (n - c) \ 26
    Loop While n > 0
    ColumnLetter = s
End Function

Sub testing()
    MsgBox (ColumnLetter(FindHeader("Search Text")))
End Sub

VBA - Finding last used row or column in Excel Worksheet

To do so we use the following lines, where mysheet is the worksheet you want to find these values for:
Dim mysheet as WorkSheet

Set mysheet = ActiveSheet

LastRow = mysheet.Cells(mysheet.Rows.Count, "A").End(xlUp).Row
LastCol = mysheet.Cells(1, mysheet.Columns.Count).End(xlToLeft).Column