VBA (Visual Basic for Applications) examples

[4fit?]

If you don’t know what VBA (Visual Basic for Applications) is, it is a child of Visual Basic that is physically built in to many programs manufactured today, including Microsoft Office.  To access the VBA editor, select ToolsMacroVisual Basic Editor from the Excel window, or simply press Alt+F11.  This will open the VBA Editor in a new window.  From here, you can insert your code into separate modules or one large one (which I don’t recommend).  Then you can call your routines from the ToolsMacroMacros window.

Sounds complicated right?  Trust me, it isn’t.  It is well worth it to learn how to use VBA.  If you can’t write your own code, that’s ok.  But you should at least be able to launch other code it if has been written by someone else.

Also, there is actually a file built into Excel to store macros for your personal use.  It is aptly called PERSONAL.XLS.  This file does not exist until you create a macro.  So, to create a bogus macro, go to ToolsMacroRecord New Macro.  In the dialog box that popups up, select Personal Macro Workbook from the Store In dropdown box and click OK.  When the macro toolbar appears, click the stop button.  That’s it.  Your PERSONAL.XLS file has been created.  Now you can place your code into that workbook in the VBA Editor and it will be available to you anytime Excel is open.  Simply go to ToolsMacroMacros and pick your desired macro.

Enough rambling. Here are a few Excel VBA subroutines that I have come up with that I use on a very regular basis.

Add full workbook name (including path) to footer

Code:

Sub CustomFooter()
    For Each sht In ActiveWorkbook.Sheets
        sht.PageSetup.LeftFooter = ActiveWorkbook.FullName
    Next sht
End Sub

Delete all empty rows without having to re-sort

Code:

Sub DeleteEmptyRows()
    LastRow = ActiveSheet.UsedRange.Row - 1 + _
        ActiveSheet.UsedRange.Rows.Count
    Application.ScreenUpdating = False
    For r = LastRow To 1 Step -1
        If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete
    Next r
End Sub

Sort by the background color of the active cells column

Code:

Sub ColorSorter()
    y = ActiveCell.Column - 1
    J = Range("IV1").End(xlToLeft).Column
    BotRow = Range("A65536").Offset(0, y).End(xlUp).Row - 1

    Range("A1").Offset(0, J) = "Sort"
    For i = 1 To BotRow
        Range("A1").Offset(i, J) = Range("A1").Offset(i, y).Interior.ColorIndex
    Next
    Cells.Sort Key1:=Range("A1").Offset(0, J), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Columns(J + 1).Delete
End Sub

Quickly get a unique count of the active column without having to use Advanced Filter

Code:

Sub UniqueCount()
    Dim Uval As New Collection
    On Error Resume Next
    If Selection.Cells.Count > 1 Then
        For Each MyRange In Selection
            Uval.Add Trim(MyRange), CStr(Trim(MyRange))
        Next
    Else
        SortCol = ColumnLetter(ActiveCell.Column)
        For i = 1 To Range(SortCol & "65536").End(xlUp).Row
            Uval.Add Trim(Range(SortCol & i)), CStr(Trim(Range(SortCol & i)))
        Next
    End If
    MsgBox Uval.Count
End Sub

Move minus (negative) sign from back of number to front

Code:

Sub MoveMinusSign()
    Dim BotRow As Long
    Dim i As Long
    BotRow = Range("A1").Offset(65535, ActiveCell.Column - 1).End(xlUp).Row
    For i = 1 To BotRow - 1
        If Len(Range("A1").Offset(i, ActiveCell.Column - 1)) > 0 Then
            If Mid(Range("A1").Offset(i, ActiveCell.Column - 1), Len(Range("A1").Offset(i, ActiveCell.Column - 1)), 1) = "-" Then _
                Range("A1").Offset(i, ActiveCell.Column - 1) = Mid(Range("A1").Offset(i, ActiveCell.Column - 1), 1, Len(Range("A1").Offset(i, ActiveCell.Column - 1)) - 1) * -1
                Range("A1").Offset(i, ActiveCell.Column - 1).NumberFormat = "0.00_);[Red](0.00)"
        End If
    Next
End Sub

Delete Empty Columns

Code:

Sub DeleteEmptyCols()
    LastCol = ActiveSheet.UsedRange.Column - 1 + _
        ActiveSheet.UsedRange.Columns.Count
    Application.ScreenUpdating = False
   
    For c = LastCol To 1 Step -1
        If IsEmpty(Cells(1, c)) And Cells(1, c).End(xlDown).Row = 65536 Then _
            Cells(1, c).EntireColumn.Delete
    Next c
    Application.ScreenUpdating = True
   
   
End Sub

Create a clickable Table Of Contents sheet for your workbook

Code:

Sub Sheet_TOC()
   
    Dim ws As Worksheet, wsNw As Worksheet, n As Integer
    Set wsNw = ActiveWorkbook.Worksheets.Add(Before:=ThisWorkbook.Sheets(1))
   
    With wsNw
        On Error GoTo 2
1:      .Name = "TOC"
        On Error GoTo 0
        .[A1] = "Table Of Contents"
        .[a2] = ActiveWorkbook.Name & " Worksheets"
        .[A1].Font.Size = 15
        .[a2].Font.Size = 11
        n = 4
        For Each ws In ActiveWorkbook.Worksheets
            If ws.Name <> .Name Then
                .Cells(n, 1) = ws.Name
                 .Hyperlinks.Add _
                    Anchor:=.Cells(n, 1), _
                    Address:="", _
                    SubAddress:="'" & ws.Name & "'!A1"
                n = n + 1
            End If
        Next
    End With
   
    Columns("A:A").EntireColumn.AutoFit
   
    Exit Sub

2:  Application.DisplayAlerts = False
    Sheets("TOC").Delete
    Application.DisplayAlerts = True
    GoTo 1

Error1:
    MsgBox "No workbook open", vbCritical, "Error"
   
End Sub

[Tags:]

Jump to: Please select a destination: ----------------------------- News and Updates ----------------------------- => G³ Solutions => News => Sites of Interest => Suggestion Box => MyWebPeople - Blogs for Normal People ===> Updates and News ===> Bug Reports ===> Feature Requests ===> Support Requests ===> MyWebPeople Blogs Feedback ----------------------------- Microsoft Windows Help ----------------------------- => Windows 9x/ME Help => Windows 2k/NT Help => Windows XP Help => Windows Vista => Windows as a Server ----------------------------- Applications - Questions, Comments, or Discussion ----------------------------- => Office Products => General Security => Help with Other Software => Favorite Software ===> Freeware Downloads => Anything Else ----------------------------- Hardware ----------------------------- => General/Advice => Diagnostics => Installing/Upgrading ----------------------------- Web Development ----------------------------- => Web Development - General ===> Web Development - Resources => Databases => Dynamic Languages => Markup Languages ----------------------------- General ----------------------------- => General and Off Topic Banter. ===> Movies and Television ===> Music ===> Games => Humor => Test => Bit Bucket