Is range within range?

To determine if the range you have, is within the range that you wish, you can use the Intersect Method in Excel VBA

In my previous example where I convert input upon change of cell I use it to ensure that I only capitalize letters within my desired range.

If Not Intersect(Target, Range("A1:Z31")) Is Nothing Then
    ConvertCaseOnRange (Target.Address)
End If

Credit: http://www.ozgrid.com/VBA/vba-intersect.htm

Close workbook after a period of inactivity

Paste this code in module1:

Const idleTime = 30 'seconds
Public isActive As Boolean
Dim Start

Sub StartTimer()

Start = Timer
Do While Timer < Start + idleTime
DoEvents
Loop
If Not isActive Then
If MsgBox("Idle for " & idleTime & " seconds. Close workbook ?", vbQuestion + vbYesNo) = vbYes Then
ActiveWorkbook.Close
Else
isActive = False
StartTimer
End If
Else
isActive = False
StartTimer
End If

End Sub

Paste this code in ThisWorkbook:

Private Sub Workbook_Open()
Module1.isActive = True
StartTimer
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Module1.isActive = True
StartTimer
End Sub

Credit: http://www.mrexcel.com/archive/VBA/7422a.html

Convert input upon change of cell

The Private Sub called Change on the specific worksheet, can be very useful if you want to modify the users input on the fly.
Select the sheet in the VB editor where you wish to capture a change, select Worksheet and Change

The range of cells that has been modified is being defined as Target.

Private Sub Worksheet_Change(ByVal Target As Range)

MsgBox Target.Address & " has just been changed"

End Sub

In this example, I convert the just changed cell(s) to capital letters
Private Sub Worksheet_Change(ByVal Target As Range)

ConvertCaseOnRange (Target.Address)

End Sub
Sub ConvertCaseOnRange(strChanged As String)
Dim rChangedCells As Range
Dim rCell As Range

Range(strChanged).Select
Set rChangedCells = Selection

' Convert to Upper Case
    Application.EnableEvents = False
    For Each rCell In rChangedCells
        rCell = StrConv(rCell, vbUpperCase)
    Next rCell
    Application.EnableEvents = True

End Sub

Timed Message Box

Private Const TM_TEXT As String = "Stop Autoopdatering?"
Private Const TM_TITLE As String = "Excel vil opdatere og eksportere filen indenfor 3 sekunder..."
Private Const TM_DURATION As Long = 3 'seconds

Sub TimedMsgbox()
Dim WSH As Object

    Set WSH = CreateObject("WScript.Shell")
    Select Case WSH.Popup(TM_TEXT, TM_DURATION, TM_TITLE, vbOKCancel)
        Case vbOK
        Case vbCancel
            Call UpdateWorkbook
            Call ExportToPDF
            'ActiveWorkbook.Close
            Application.Quit
        Case -1
            Call UpdateWorkbook
            Call ExportToPDF
            'ActiveWorkbook.Close
            Application.Quit
        Case Else
    End Select

End Sub

Find Date Version 2

This sub enables you to locate a date, based on excel sheet where you have divided your month and days displayed in separate cells e.g. like this:

Sub FindDateV2()

    Dim strDate As String
    Dim rCell As Range
    Dim lReply As Long
    Dim strColumnNbr

    strDay = Right("0" & DatePart("d", Date), 2)

    Select Case Month(Date)
        Case 1
            strMonth = "January"
        Case 2
            strMonth = "February"
        Case 3
            strMonth = "March"
        Case 4
            strMonth = "April"
        Case 5
            strMonth = "May"
        Case 6
            strMonth = "June"
        Case 7
            strMonth = "July"
        Case 8
            strMonth = "August"
        Case 9
            strMonth = "September"
        Case 10
            strMonth = "October"
        Case 11
            strMonth = "November"
        Case 12
            strMonth = "December"
    End Select

    On Error Resume Next

    Set rMonth = Cells.Find(What:=strMonth, After:=Range("A1"), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    Application.GoTo rMonth
    ActiveCell.Offset(3, 0).Select

    If strDay <> "01" Then
        Set rDay = Cells.Find(What:=strDay, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        Application.GoTo rDay
    End If

    On Error GoTo 0

    strColumnNbr = ActiveCell.Column
    ActiveWindow.ScrollColumn = strColumnNbr

End Sub

Find today’s date in sheet

Sub FindDate()

    Dim strDate As String
    Dim rCell As Range
    Dim lReply As Long
    Dim strColumnNbr
 
    strDate = Format(Date, "short date")

    On Error Resume Next

    Set rCell = Cells.Find(What:=CDate(strDate), After:=Range("A1"), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    On Error GoTo 0



    If rCell Is Nothing Then
        lReply = MsgBox("Today's date could not be found in the sheet.", vbOKOnly, "Auto Search Date Function")
        End
    Else
        Application.GoTo rCell
        strColumnNbr = ActiveCell.Column
        strColumnNbr = strColumnNbr - 6
        ActiveWindow.ScrollColumn = strColumnNbr
        ActiveCell.Offset(0, 0).Select
    End If

End Sub

Count colored cells

One of the most useful functions I have found, has been made by Flemming Dahl from www.smartoffice.dk
I have used it for work schedule or other planning, where you need to have a visual overview but at the same time count the cells, e.g. as hours, in a given area.

  1. Go to the code function area in your workbook by right clicking your Sheet Tab, and choose “View Code”
  2. Go to the menu and select INSERT -> MODULE
  3. Add the function to the new MODULE by copy/paste it in.
  4. To use the function select your area,  point to a cell with the color you wish to count in your range.
  • E.g. In Cell A2, add the following =ColoredCellsCount(B1:B20;A1) this will count all cells in column B from row 1 to 20, that equals same color in Cell A1
  • Now activate Cell A1 and choose a color, e.g. blue
  • Do the same with a few cells in column B, and see the count.
Option Explicit
Public Function ColoredCellsCount(rCountArea As Range, rCountColor As Range) As Double
'Flemming Dahl, Januar 2002, fd@smartoffice.dk
    Application.Volatile
    Dim dRetVal As Double
    Dim rCell As Range
    Dim iColor As Integer
    For Each rCell In rCountArea
        If rCell.Interior.ColorIndex = rCountColor.Interior.ColorIndex Then
            dRetVal = dRetVal + 1
        End If
    Next rCell
    ColoredCellsCount = dRetVal
    ' Clean up
    Set rCell = Nothing
End Function

Now remember that your Excel file must be saved as Macro-enabled file type (.xlsm) to save macroes in your file.

Style copy

Yesterday I discovered a new feature in the office pack, that was new to me – the Format painter.

Basically it just enables you go copy a formatting for a given object, to another object.

Now not only is it accessible through a button in MS Office 2007 programs, but it also has 2 shortcuts that actually makes sense.

CTRL+SHIFT+C to copy a given format
and
CTRL+SHIFT+V to apply the copied format to a given object.

Pretty nice feature.