Good Excel Practical Jokes, Pranks, Mean Tricks, etc.


Board Regular
Nov 16, 2008
I had a minor complaint/Comparison with another dude that my sheets weren't very colourful, and his were. So I wrote this:
My boss finally fell victim to this, this morning. Much laughter was heard. Very worth it, especially in conjunction with the
MsgBox "Is that colourful enough, boss?"

Some videos you may like

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.


Board Regular
May 16, 2015
I'm new here but I'm loving this thread. These pranks are great! One of my favorite VBA pranks is to change my coworker's mouse cursor to a dancing banana (from the Peanut Butter Jelly Time video here:

I had a colleague do this to me once and I thought it was brilliant. It actually saves the cursor byte string to your custom document properties so they don't have to download anything. The byte string is "rebuilt" and activated each time the document is opened. Clever! You can read about it here if you want:VBA Office Prank Dancing Banana Cursor - Ryan Wells


New Member
Jun 9, 2015
I've been throwing in links to images and just playing the waiting game when the if condition is correct. Sometimes I'll use mr hanky(example code given), others i'll look for the scariest picture I can think of and have it activate if someone is using the workbook at 3am-430am. was looking into a way of making it also play a sound through excel and not an external program

ActiveWorkbook.FollowHyperlink ""


New Member
May 25, 2012
Outstanding lol!!!

thought i would bring this thread back with a new one i thought of this morning.

This code when run will start randomly moving the cells around (at least it will look like it is).
It works by randomly choosing two cells in the activewindow creating a images of those cells and placing them over the cells and then swapping their locations.

Call gocrazy to start the macro.
Press f12 to exit the loop.

If you use ctrl+break to exit, you will need to manually run the curecrazy sub which removes all created shapes.

You can set the worksheet_activate event to call gocrazy and then when a user goes to the specified sheet, the craziness will begin.
Note: This works best on a sheet with lots of data and variations to colors, etc. Just because you can see everything moving around easily.
It is actually pretty disconcerting to watch even though i know there is a simple undo to cure the crazy. :LOL:

private declare function getasynckeystate lib "user32" (byval vkey as long) as integer
const vk_f12 = &h7b
private crazy as boolean
sub gocrazy()
dim lo_c as long, hi_c as long
dim lo_r as long, hi_r as long
dim c1 as range, c2 as range
dim shp1 as shape, shp2 as shape
dim tmpleft as long, tmptop as long, tmpwidth as long, tmpheight as long
dim shpcount as long
crazy = true

    application.onkey "{f12}", ""
    do while crazy
        lo_c = activewindow.visiblerange.resize(1, 1).column
        hi_c = activewindow.visiblerange.columns.count + lo_c - 1
        lo_r = activewindow.visiblerange.resize(1, 1).row
        hi_r = activewindow.visiblerange.rows.count + lo_r - 1
        col1 = int((hi_c - lo_c + 1) * rnd + lo_c)
        col2 = int((hi_c - lo_c + 1) * rnd + lo_c)
        row1 = int((hi_r - lo_r + 1) * rnd + lo_r)
        row2 = int((hi_r - lo_r + 1) * rnd + lo_r)
        set c1 = activewindow.activesheet.cells(row1, col1)
        set c2 = activewindow.activesheet.cells(row2, col2)
        set shp1 = getshape(c1)
        set shp2 = getshape(c2)
        if shp1 is nothing then
            set shp1 = createcrazy(c1, shpcount)
            shpcount = shpcount + 1
        end if
        if shp2 is nothing then
            set shp2 = createcrazy(c2, shpcount)
            shpcount = shpcount + 1
        end if
        tmpleft = shp1.left
        tmptop =
        tmpwidth = shp1.width
        tmpheight = shp1.height
        shp1.left = shp2.left =
        shp1.width = shp2.width
        shp1.height = shp2.height
        shp2.left = tmpleft = tmptop
        shp2.width = tmpwidth
        shp2.height = tmpheight
        if getasynckeystate(vk_f12) then stopcrazy
    application.onkey "{f12}"
end sub
sub stopcrazy()
    crazy = false
end sub
function createcrazy(cll as range, num as long) as shape
dim newshape as shape
set currselect = selection
    application.screenupdating = false
        activewindow.activesheet.paste cll
        set newshape = getshape(cll) = "crazyshp" & num
        newshape.fill.visible = msotrue
        newshape.line.visible = msofalse
    application.screenupdating = true
    set createcrazy = newshape
end function
private function getshape(rngselect as range) as shape
dim shp as shape
    for each shp in rngselect.worksheet.shapes
        if not intersect(range(shp.topleftcell, shp.bottomrightcell), rngselect) is nothing then
            goto shapefound
        end if
    set getshape = nothing
    exit function
    Set getshape = shp
end function

sub curecrazy()
dim shp as shape
    for each shp in activewindow.activesheet.shapes
        if like "crazyshp*" then shp.delete
    next shp
end sub


Board Regular
May 16, 2015
I've got a new prank for you!

Many people don't know this, but you can actually change content of other cells using a VBA user-defined function. Today, I created a function that I can hide way over on the right side of an Excel sheet. Anytime someone tries typing into a cell in Excel, a different funny message will fill the cell where they just tried typing. Being able to run this prank from a UDF instead of a worksheet change event (the typical way to run similar pranks) is awesome! The 4th example here shows the custom function:

How to Change Another Cell with a VBA Function (Scroll down to the last example to see the prank in action)

Once you copy and paste the macro, just enter =MeanFunction() into any cell in Excel. The user is trapped until he finds out which cell it was typed in. The function returns an empty string in its own cell, so it's even harder to find.

This might be even better than the ole VBA prank to change your cursor to a dancing banana!


Well-known Member
Jan 23, 2012
OK, since this thread has had a surge of life lately, I just recently worked up this fun one for a co-worker who is always leaving his terminal unlocked....(to go catch Pokemon apparently) :rolleyes:

Just create a workbook with the following code (and userform) in the modules specified and viola, an infinite loop of annoying (but fun) reminder messages to lock your computer.

in the ThisWorkbook module:
Private Declare Function LockWorkStation Lib "user32.dll" () As Long
Private Sub Workbook_BeforeClose(Cancel As Boolean)
End Sub
Private Sub Workbook_Open()
End Sub
In a standard module:
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Public Declare Function GetSystemMetrics Lib "user32.dll" (ByVal index As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1
Const VK_F12 = &H7B
Public RUN_TIMER As Double
Public oldT As Double
Public oldH As Double
Public oldW As Double
    Application.WindowState = xlNormal
    oldW = Application.Width
    oldH = Application.Height
    oldT = Application.Top
    Application.Width = 10
    Application.Height = 10
    Application.Top = -100
    Application.OnKey "{F12}", ""
        Application.WindowState = xlNormal
        RUN_TIMER = Now + TimeValue("00:00:10")
        If GetAsyncKeyState(VK_F12) Then GoTo LOOPBREAK
    Application.OnKey "{F12}"
End Sub
If RUN_TIMER = 0 Then End
On Error Resume Next
    Application.OnTime RUN_TIMER, "MINIMIZE_ALL_ELSE", , False
    Application.WindowState = xlNormal
    RUN_TIMER = Now + TimeValue("00:00:10")
    Application.OnTime RUN_TIMER, "MINIMIZE_ALL_ELSE", , True
End Sub

    Application.OnTime RUN_TIMER, "MINIMIZE_ALL_ELSE", , False
    RUN_TIMER = 0
    Application.Visible = True
    Application.WindowState = xlNormal
    MsgBox "Hopefully you have learned your lesson." & vbCrLf & _
        "LOCK TERMINAL?", vbCritical, "Locking terminal"
    Application.Width = oldW
    Application.Height = oldH
    Application.Top = oldT
    ThisWorkbook.Close False
End Sub

Create a UserForm (to look like a MsgBox) with a caption field named 'lblText' and an OK button called 'btnOK'
In the code section of that UserForm:
Private Sub btnOK_Click()
    Unload Me
End Sub
Private Sub UserForm_Activate()
msgstr = Array( _
    "Next time I will lock my terminal.", _
    "Terminal Unlock Status: VERIFIED" & vbCrLf & "Status: VULNERABLE" & vbCrLf & "Condition:  :(", _
    "I have been left unlocked.  Now I am FREEeee!", _
    "Is your computer running?                                               " & vbCrLf & "Well you better go and catch it." & vbCrLf & "LOLOLOL", _
    "Which way did the programmer go?                                        " & vbCrLf & "He went DATA way.", _
    "Do computers dream in binary?", _
    "10001001011010011010010011101110111010001000001 0101010 101010101001111011011" & vbCrLf & vbCrLf & "If you were a computer you'd understand.", _
    "Let's play a game.  Try to guess where will I pop up next.", _
    "Calculating the square root of infinity", _
    "There IS a way to make this stop.                                       " & vbCrLf & "Just kidding.  This will go on forever now.", _
    "Why, oh why, didn't you lock me.", _
    "Wake up Neo.                                                            " & vbCrLf & "The MATRIX has you.", _
    "I am a jelly doughnut.")
    With Me
        .StartUpPosition = 0
        .Left = .Width + Rnd() * (GetSystemMetrics(SM_CXSCREEN) - .Width)
        .Top = .Height + Rnd() * (GetSystemMetrics(SM_CYSCREEN) / 2 - .Height)
    End With
    Randomize Now()
    R = Int(Rnd() * (UBound(msgstr) + 1)) + LBound(msgstr)
    For i = 1 To Len(msgstr(R))
        Me.lblText.Caption = Left(msgstr(R), i)
        Sleep 20
    Next i
End Sub

Private Sub UserForm_Deactivate()
End Sub
You can hold down F12 when pressing the OK button to exit the loop at any time.
Added bonus:
-Every 10 seconds, all other windows but the UserForm are minimized so they can't just ignore the message


New Member
Jul 22, 2016
I created an account to leave this here...

To enable it, goto tools ~> References and select "Microsoft Internet Controls"

Private Sub Workbook_Open()
Dim ie As InternetExplorer
Set ie = New InternetExplorer
ie.Navigate ("") 'Put whatever youtube stuff you want here.
End Sub
opens an invisible IE window to play a video. If the users PC is not muted... Oh joy. I know theres code out there to unmute and turn up a pc, but I didn't want to be too mean.


Well-known Member
Oct 15, 2013
In honor of yesterday being "Talk like a pirate day".... you could combine the speak function to make the workbook literally talk like a pirate. The following will store the text of the active cell and when the selection is changed, audibly speak the string in pirate jargon.

Note: more fun if this is applied to a workbook where text is entered frequently.

Standard Module:
Public str As String

Function PirateSpeak(normalText As String) As String

    Const BASE_URL As String = ""
    Dim msxml As clsMSXML
    Dim xml As Object   ' MSXML2.XMLHTTP60
    Dim result As String
    Set msxml = New clsMSXML
    Set xml = msxml.GetMSXML
    result = msxml.GetResponse(xml, HTTP_GET, _
        BASE_URL & normalText, False)
    PirateSpeak = result
End Function
ThisWorkbook code:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
str = Target.value
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Not str = "" Then
    Application.Speech.Speak PirateSpeak(str)
    str = ""
End If
End Sub
Class Module: Rename to clsMSXML
Option Explicit
' ***********************************************************************
' private vars
' ***********************************************************************
' change this to "" if you want version 2
Private Const VERSION As String = "6.0"
' ***********************************************************************
' enums
' ***********************************************************************
Public Enum HTTPRequestType
End Enum
' ***********************************************************************
' internal class functions
' ***********************************************************************
Private Function GetRequestType(reqType As HTTPRequestType) As String
' translate enum into string
  Select Case reqType
  Case 1
    GetRequestType = "POST"
  Case 2
    GetRequestType = "HEAD"
  Case Else  ' GET is default
    GetRequestType = "GET"
  End Select
End Function
' ***********************************************************************
' major objects
' ***********************************************************************
Public Function GetMSXML() As Object  ' MSXML2.XMLHTTP60
  On Error Resume Next
  Set GetMSXML = CreateObject("MSXML2.XMLHTTP" & IIf(Len(VERSION) = 0, "", "." & VERSION))
End Function
Function GetDomDoc() As Object  ' MSXML2.DOMDocument
  On Error Resume Next
  Set GetDomDoc = CreateObject("MSXML2.DOMDocument" & IIf(Len(VERSION) = 0, "", "." & VERSION))
End Function
Function GetMXXMLWriter() As Object
  On Error Resume Next
  Set GetMXXMLWriter = CreateObject("MSXML2.MXXMLWriter" & IIf(Len(VERSION) = 0, "", "." & VERSION))
End Function
Function CreateHTMLDoc() As Object  ' MSHTML.HTMLDocument
  On Error Resume Next
  Set CreateHTMLDoc = CreateObject("htmlfile")
End Function
' ***********************************************************************
' nodes
' ***********************************************************************
Function GetNode(parentNode As Object, nodeNumber As Long) As Object
  On Error Resume Next
  ' if parentNode is a MSXML2.IXMLDOMNodeList
  Set GetNode = parentNode.item(nodeNumber - 1)
  ' if parentNode is a MSXML2.IXMLDOMNode
  If GetNode Is Nothing Then
    Set GetNode = parentNode.childNodes(nodeNumber - 1)
  End If
End Function
Public Function GetChildNodes(node As Object) As Object
' returns child nodes for a given MSXML2.IXMLDOMNode
  Set GetChildNodes = node.childNodes
End Function
Function GetRootNode(xmlDoc As Object) As Object
' returns root node
  Set GetRootNode = xmlDoc.documentElement
End Function
' ***********************************************************************
' error checking
' ***********************************************************************
Function LoadError(xmlDoc As Object) As Boolean
' checks if a xml file load error occurred
  LoadError = (xmlDoc.parseError.errorCode <> 0)
End Function
' ***********************************************************************
' maintenance
' ***********************************************************************
Function ClearCache(Optional fileExtension As String = "xml")
' deletes stored xml files from temp folder
  Dim filesToDelete As String
  filesToDelete = Environ("temp") & "\*." & fileExtension
  Kill filesToDelete
End Function
Function CreateFile(fileName As String, contents As String) As String
' creates file from string contents
  Dim tempFile As String
  Dim nextFileNum As Long
  nextFileNum = FreeFile
  tempFile = fileName
  Open tempFile For Output As #nextFileNum
  Print #nextFileNum, contents
  Close #nextFileNum
  CreateFile = tempFile
End Function
' ***********************************************************************
' string operations
' ***********************************************************************
Function ConvertAccent(ByVal inputString As String) As String
  Const AccChars As String = _
  Const RegChars As String = _
  Dim i As Long, j As Long
  Dim tempString As String
  Dim currentCharacter As String
  Dim found As Boolean
  Dim foundPosition As Long
  tempString = inputString
  ' loop through the shorter string
  Select Case True
  Case Len(AccChars) <= Len(inputString)
    ' accent character list is shorter (or same)
    ' loop through accent character string
    For i = 1 To Len(AccChars)
      ' get next accent character
      currentCharacter = Mid$(AccChars, i, 1)
      ' replace with corresponding character in "regular" array
      If InStr(tempString, currentCharacter) > 0 Then
        tempString = Replace(tempString, currentCharacter, _
                             Mid$(RegChars, i, 1))
      End If
    Next i
  Case Len(AccChars) > Len(inputString)
    ' input string is shorter
    ' loop through input string
    For i = 1 To Len(inputString)
      ' grab current character from input string and
      ' determine if it is a special char
      currentCharacter = Mid$(inputString, i, 1)
      found = (InStr(AccChars, currentCharacter) > 0)
      If found Then
        ' find position of special character in special array
        foundPosition = InStr(AccChars, currentCharacter)
        ' replace with corresponding character in "regular" array
        tempString = Replace(tempString, currentCharacter, _
                             Mid$(RegChars, foundPosition, 1))
      End If
    Next i
  End Select
  ConvertAccent = tempString
End Function
Function FixAngleBrackets(textString As String) As String
  FixAngleBrackets = Replace(Replace(textString, "<", "<"), ">", ">")
End Function
Function URLEncode(EncodeStr As String) As String
  Dim i As Integer
  Dim erg As String

  erg = EncodeStr
  ' *** First replace '%' chr
  erg = Replace(erg, "%", Chr(1))
  ' *** then '+' chr
  erg = Replace(erg, "+", Chr(2))
  For i = 0 To 255
    Select Case i
      ' *** Allowed 'regular' characters
    Case 37, 43, 48 To 57, 65 To 90, 97 To 122
    Case 1  ' *** Replace original %
      erg = Replace(erg, Chr(i), "%25")
    Case 2  ' *** Replace original +
      erg = Replace(erg, Chr(i), "%2B")
    Case 32
      erg = Replace(erg, Chr(i), "+")
    Case 3 To 15
      erg = Replace(erg, Chr(i), "%0" & Hex(i))
    Case Else
      erg = Replace(erg, Chr(i), "%" & Hex(i))
    End Select
  URLEncode = erg
End Function
Function ExtractFileName(fileName As String) As String
' extract filename portion of filename, no extension
  Dim fileN As String

  fileN = Right(fileName, Len(fileName) - InStrRev(fileName, "\"))
  fileN = Replace(fileN, GetFileType(fileN), "")

  ExtractFileName = fileN
End Function
Function GetFileType(fileName As String) As String
' get file extension
  GetFileType = Mid$(fileName, InStrRev(fileName, "."), Len(fileName))
End Function
' ***********************************************************************
' read/write operations
' ***********************************************************************
Function CreateXML(inputValues As Variant, _
                   Optional filePath As String, _
                   Optional parentNodeName As String = "Values", _
                   Optional returnXML As Boolean = 1) As String
' see
' validated using
  Dim pathName As String
  Dim xmlDoc As Object  ' MSXML2.DOMDocument60
  Dim mxxml As Object  ' MSXML2.MXXMLWriter60
  Dim cnth As Object  ' MSXML2.IVBSAXContentHandler
  Dim i As Long, j As Long

  ' create new DOM Document and point XML writer to it
  Set xmlDoc = GetDomDoc

  If xmlDoc Is Nothing Then
    MsgBox "Could not create MSXML DOM Document."
    Exit Function
  End If

  Set mxxml = GetMXXMLWriter
  If mxxml Is Nothing Then
    MsgBox "Could not create MXXML Writer"
    Exit Function
  End If

  Set cnth = mxxml
  mxxml.output = xmlDoc
  mxxml.indent = True

  ' begin creating the XML document output
  ' add xml declaration
  cnth.processingInstruction "xml", "version='1.0' encoding='UTF-8'"

  ' create parent node using input name or default of "Values"
  cnth.startElement "", "", parentNodeName, Nothing

  ' create first-level child nodes using first row of array
  For i = LBound(inputValues, 2) To UBound(inputValues, 2)
    cnth.startElement "", "", CStr(inputValues(1, i)), Nothing
    ' loop through array and create a child node for each
    ' since parent node hasn't been closed, these will automatically be child nodes
    For j = 2 To UBound(inputValues)
      cnth.startElement "", "", "Value", Nothing
      cnth.Characters CStr(inputValues(j, i))
      cnth.endElement "", "", "Value"
    Next j
    ' close parent node
    cnth.endElement "", "", CStr(inputValues(1, i))
  Next i

  ' close parent node
  cnth.endElement "", "", parentNodeName
  ' end output

  ' save xml?
  If Len(filePath) > 0 Then
    ' verify folder exists
    pathName = Split(filePath, ExtractFileName(filePath))(0)
    If FolderExists(pathName) Then
      ' save xml to specified filepath
      xmlDoc.Save filePath
    End If
  Else  ' return xml
    returnXML = 1
  End If

  ' return xml?
  If returnXML Then
    CreateXML = xmlDoc.xml
  End If

End Function
Function ReadXML(fileName As String) As String()
' see
  Dim xmlDoc As Object  ' MSXML2.DOMDocument60
  Dim myvalues As Object  ' MSXML2.IXMLDOMNode
  Dim values As Object  ' MSXML2.IXMLDOMNode
  Dim value As Object  ' MSXML2.IXMLDOMNode
  Dim tempString() As String
  Dim numRows As Long, numColumns As Long
  Dim i As Long, j As Long

  ' check if file exists
  If Len(Dir(fileName)) = 0 Then Exit Function

  ' create MSXML 6.0 document and load existing file
  Set xmlDoc = GetDomDoc
  If xmlDoc Is Nothing Then Exit Function
  xmlDoc.Load fileName
  If LoadError(xmlDoc) Then Exit Function

  ' second node starts the node tree
  Set myvalues = GetNode(xmlDoc, 2)
  ' array size? add +1 for header row
  numColumns = myvalues.childNodes.Length
  numRows = GetNode(myvalues, 1).childNodes.Length + 1
  ReDim tempString(1 To numColumns, 1 To numRows)

  For i = 1 To numColumns
    Set values = GetNode(myvalues, i)
    ' first value in every column is node name
    tempString(i, 1) = values.nodeName

    For j = 1 To numRows - 1
      tempString(i, j + 1) = GetNode(values, j).nodeTypedValue
    Next j

  Next i

  ReadXML = tempString

End Function

Function GetResponse(xml As Object, _
                     requestType As HTTPRequestType, _
                     destinationURL As String, _
                     Optional async As Boolean, _
                     Optional requestHeaders As Variant, _
                     Optional postContent As String) As String

  Dim reqType As String
  Dim response As String
  Dim i As Long

  ' translate enum into string
  reqType = GetRequestType(requestType)

  ' open request
  With xml
    .Open reqType, destinationURL, async

    ' check for headers
    If Not IsMissing(requestHeaders) Then
      If Not IsEmpty(requestHeaders) Then
        For i = LBound(requestHeaders) To UBound(requestHeaders)
          .setRequestHeader requestHeaders(i, 1), requestHeaders(i, 2)
        Next i
      End If
    End If

    ' if HTTP POST, need to send contents, will not
    ' harm GET or HEAD requests
    .send postContent

    ' if HEAD request, return headers, not response
    If reqType = "HEAD" Then
      response = xml.getAllResponseHeaders
      response = xml.responseText
    End If

  End With

  GetResponse = response
End Function

Function FolderExists(foldername As String) As Boolean
  FolderExists = (Len(Dir(foldername)) > 0)
End Function


New Member
Oct 19, 2016
How about having a macro that plays a paricularly loud and long wav file on entry of data into a particular cell - enough to cause panic in many colleagues when the boss is prowling about
Yeah, love this idea, though my crude mind immediately went to fart noises.

Watch MrExcel Video

Forum statistics

Latest member
Raghav Chamadiya

This Week's Hot Topics