VideoPhoto

30 January, 2022

Unique Macro Buttons - Unlimited

If you use macros (VBA code) in Excel you probably use macro buttons as well. There are many ways to create them, but the one I like the most is to utilize just the Excel cells. Yes, nothing else but the cells. Cells are 'pictures'. Obviously, if you'd like to "decorate" them in any way, you could; and at least you'd probably like to mark them somehow in order to recognize that they hold your macro code.

So, you'd start with selecting a cell and entering some (centered) text into it, e.g. 'Run abc...'. Next, to create the button, you'd:

  • copy the cell (using CTRL+C shortcut) and paste it to the same cell (or another - it's your choice) as a Picture (using ALT+H+V+U shortcut)
  • right-click in the cell and select Size & Properties > Properties and select Move & size with cells option (this way the 'picture' will always fit and stay in the same cell)
  • right-click again, select Assign Macro... from the menu and select your macro from the list you'd see in Assign Macro dialog

The cell is now your macro button. Click it to run your assigned macro.

If you'd like to make the button more distinct (visible) you'd add some shape or photo or icon and/or format the cell at your will (prior to pasting it (!) as a Picture). Here is a couple of ideas, if you want to make the button unique:

29 January, 2022

Unique Advanced Filtering

Advanced filtering in Excel is in fact nothing new in recent years, but it is a very useful feature, worth revisiting and reminding its role in data analysis and presentation. In the following example I demonstrate how you can filter the selected data (a list in this case) to show the unique names/IDs, based on just one simple criteria. Not only that; at the same time you can get an additional information - number of times each of the unique names/IDs appears in the list. Here's the setup and the result:

27 January, 2022

Using Excel as Music Player

Do you like to listen in the background to your favourite music while working outside Excel, e.g. in Word, or on your emails? If so, you can use Excel as a music player. To prepare for that you need to create a music library, collection of your music files, located e.g. in MyMusic subdirectory, as in my example.

Having done that, next create in your Excel worksheet a list of Hyperlinks to those files (by using CTRL+K shortcut for each of your music files). The list can be arranged in any order and contain as many hyperlinks as needed. Here is a short example of my list:

24 January, 2022

23 January, 2022

Creating Pixel Art - Iterations

You can use Excel to create some work of art. Over 32000 iterations can be utilized, and this allows to produce lots of pixels in your worksheet and, practically, create unlimited number of 2D 'pictures' and 3D 'sculptures'. All you need is to use the two macros presented at the end of this post (one for drawing and the other for erasing) and some creativity, obviously.

To give you an idea what kind of 'art' I'm talking about, here are just couple of examples:

 

 


Before starting your creative work you need to determine name for your picture. Go to Formulas > Define Name in your workbook and enter TRI in the Name: field and =Sheet1!$B$2:$ZZ$601 in Refers to: field.

Next, insert and format two Buttons (Form Controls) similar to what you see here:

Goto to Developer > Insert > Button, add the text (Draw..., Erase...) and assign the two macros to them. You'll use the buttons to create and erase the pictures.

Now you can copy the macros listed below to one of the modules inserted in your workbook (VBAProject). At this point you're ready to start experimenting with the pixel art. There are several parameters (variables) plus functions, formulas, equations, colors etc. that can be changed and manipulated at will.

Here are the macros:

Option Explicit
Sub Sculpture()
'Produces graphics: from random mist to well defined pixel art
'Use provided parameters and translations to define "sculptures"
'Takes several seconds to produce some pixel art

Dim cP(3) As Long
Dim wid As Double
Dim myPts As Single
Dim myRange As Range
Dim cx As Double, cy As Double, rC As Double, iC As Double
Dim xUL As Double, xLL As Double, yUL As Double, yLL As Double
Dim y As Double, x As Double, c As Double, d As Double
Dim intW As Integer, intH As Integer, i As Integer, j As Integer
Dim a As Single, b As Single, sPercent As Single, co As Single
'Color palette; change as needed
cP(0) = 65280       'green
cP(1) = 65535       'yellow
cP(2) = 13382400    'blue
cP(3) = 255         'red
On Error GoTo TheEnd
'Set your canvas range for square cells; here set to B2:ZZ601
Set myRange = Application.InputBox("Select a range in which to create square cells", ,  _"$B$2:$ZZ$601", Type:=8)
On Error Resume Next
If myRange.Cells.Count = 0 Then Exit Sub
GetWidth:       'Set the width of cells (0.08 is my screen pixel size)
wid = Val(InputBox("Input Column Width:", , "0.08"))
If wid < 0.08 Then
    MsgBox "Invalid column width value"
    GoTo GetWidth
End If
Application.ScreenUpdating = False
myRange.EntireColumn.ColumnWidth = wid
myPts = myRange(1).Width        'Set row height
myRange.EntireRow.RowHeight = myPts
xLL = -1.02: xUL = 3.02: yLL = -1.02: yUL = 2.59
intW = myRange.Columns.Count: intH = myRange.Rows.Count
Application.Goto reference:="TRI"   'TRI is the named range (=Sheet1!$B$2:$ZZ$601")
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 0   'Background color; set to black
End With
Range("A1").Select
x = 0: y = 0
cx = 1: cy = 0.5
a = Rnd() * (-10 - 10) + 10: b = Rnd() * (-10 - 10) + 10  'Random real numbers between -10 & 10
For j = 1 To 4      'Iterate by colors
    Select Case j
        Case 1
            co = cP(0)
        Case 2
            co = cP(1)
        Case 3
            co = cP(2)
        Case Else
            co = cP(3)
    End Select
    For i = 1 To 30000  'Number of iterations with each of the colors
        x = cx: y = cy
        c = Sin(a * x): d = Cos(b * y ^ 2)  'Use any other formulas to get desirable results
        cx = d + c * c + 0.6: cy = Sin(2 * a * x) - Sin(c) * d + 0.8    'As above
        iC = Int(intW * (cx - xLL) / (xUL - xLL)): rC = Int(intH * (cy - yLL) / (yUL - yLL))
        myRange.Cells(1 + rC, 1 + iC).Interior.Color = co
        If iC < 2 Then iC = 2: If iC > intW Then iC = intW
        If rC < 2 Then rC = 2: If rC > intH Then rC = intH
    Next i
Next j
Range("Sheet1!B1").Select
myRange.Cells(1, 1).Offset(-1, 0) = "Basic parameters used: a=" & Format(a, "#0.0;-#0.0") & ", b=" & _Format(b, "#0.0;-#0.0")
Application.ScreenUpdating = True
myRange.Cells(1, 1).Offset(-1, -1).Select
TheEnd:
Set myRange = Nothing
If Application.ScreenUpdating = False Then Application.ScreenUpdating = True
End Sub
 

Sub EraseSculpt()
'Clear the graphic and restore cell size
Dim TRI As Name
Application.ScreenUpdating = False
    Application.Goto reference:="TRI"
    Selection.Clear
    With Selection
        .ColumnWidth = 8.43
        .RowHeight = 12.75
    End With
    Range("B1").Select
    Selection.ClearContents
    Range("A2").Select
Application.ScreenUpdating = True
End Sub

 

20 January, 2022

Animation - Flying Objects

The following VBA (Visual Basic Application) code makes Excel shapes and some other graphics flying. In this instance I'm shooting a rocket on my worksheet across the computer screen. This shape is based on Excel graphic named "Graphic 4".

Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal iMilliseconds As Long)

Sub Flyer()
    Sheet1.Shapes("Graphic 4").Left = 1000   'Starting X
    Sheet1.Shapes("Graphic 4").Top = 450   'Starting Y
    MoveShp Sheet1.Shapes("Graphic 4"), 0!, 0!, #12:00:01 AM#   'Shape inserted
End Sub
Sub MoveShp(shp As Shape, ByVal coLeft As Single, ByVal coTop As Single, t As Date)
' Moves the shape from start to finish over the interval t
    Const xch = 0.018
    Const n1 As Long = 30       'Accelerate/decelerate steps
    Const n2 As Long = 60   'Coast steps
    Const n As Long = 2 * n1 + n2    'Total steps
    Dim i As Long   'Step index
    Dim stpv As Single   'Coasting, pixels/step
    Dim v As Single     'Velocity at current step
    Dim cLiLeft As Single, cLiTop As Single   'Left and Top num
    Dim cMi As Single      'Frctn denom
    Dim coLeftPr As Single, coTopPr As Single  'Previous Left and Top position
    stpv = 1 / (n - n1)
    With shp
        coLeft = coLeft - .Left: coTop = coTop - .Top
        coLeftPr = .Left: coTopPr = .Top
        For i = 1 To n
            Select Case i
            Case 1 To n1    'Accelerate
                v = stpv * (1 + Cos(xch * 180 * (1 + i / n1))) / 2
            Case n1 + 1 To n - n1   'Constant velocity
                v = stpv
            Case Else       'Decelerate
                v = stpv * (1 + Cos(xch * 180 * (1 + (n - i) / n1))) / 2
            End Select
            .Left = .Left + v * (coLeft - cLiLeft) / (1 - cMi)
            .Top = .Top + v * (coTop - cLiTop) / (1 - cMi)
            cMi = cMi + v
            cLiLeft = .Left - coLeftPr: cLiTop = .Top - coTopPr
            DoEvents
            Sleep t * 86400000# / n
        Next i
    End With
End Sub

To use the code in Excel on your computer follow these steps:

  • find and insert Graphic 4 shape into your worksheet (if you want to use any other Excel graphic, remember to change the shape name in the above code)
  • copy the code and paste it into any module of your project (workbook)
  • select the "Flyer" macro from Macros in the ribbon to run it.

If you assign the macro to the shape (by right-clicking it and selecting "Assign Macro..." option), then just click on the shape and it will fly...

Try to run it using some other shapes/objects.

 

 

17 January, 2022

Calculating an AVERAGE between any two dates

You've created a table which contains a column with dates. Now you need to do some calculations on numeric data included between some two selected dates. E.g., you want to calculate average of some 'Output' numbers falling within one month, December 2021, like in this table:


If your table is sorted by the 'Date' column, the simplest way to get your average 'Output' is as follows: