I heard about 3D Objects from MrExcel. I’ve had fun combing a 3D model with VBA (it moves inside your spreadsheet!)

3D Objects

They have few practical uses but are fun to play with. In MrExcel’s words:

Unless you are an engineer, I am not sure how 3D Models has a business use. But it is a cool new feature.

MrExcel.com

I agree completely…not practical but definitely fun to play with.

Test: insert 3D Model

(older versions don’t have this feature). Follow these steps:

1. on ribbon select Insert
2. select Illustrations
3. select 3D Models
4. select Stock 3D models (select an ‘animated’ one!)
5. select green Insert button

Once inserted you’ll notice it’s animated and you’ll see various options.

Why Use a 3D Model?

I used it to practice VBA . It’s silly but I learned/relearned a ton of VBA.

What Did I Do?

I added VBA so the dinosaur can move around and eat people!

Odd that the dinosaur is smaller than the people but you can resize them.

Instructions:

1. click ‘Start’ button (repositions objects and resets stats)
2. if dinosaur isn’t animated click it’s play button
3. click green arrows to move the dinosaur
4. figure out how to eat people (hints at bottom of post)

Where’s My Excel File?

It’s too large to include here but I explain how to rebuild it below.

Rebuilding My Excel File

XLSM Shell File

This small file has formulas, code, named ranges, buttons (but not the heavy 3D object).

Insert 3D Object & Icons

Insert 3D Dinosaur

Once again, steps to insert the dinosaur:

1. on ribbon select Insert
2. select illustrations
3. select 3D models
4. select dinosaur as seen below
5. select green Insert button

Rename the dinosaur:

1. ensure dinosaur is selected
2. in name box (left of formula bar) rename it to Dino1
3. press ‘Enter’ key to save changes

Note: the Excel file will now be about 28MB !!

Insert Cutout People

To insert cutout people icons:

1. on ribbon select Insert
2. select illustrations
3. select icons
4. select 5 Cutout People
5. select green Insert button

To resize cutout people icons:

1. select a person
2. select ‘Picture Format’ on the ribbon
3. resize to similar dimensions as pic below

To rename cutout people icons:

1. select a person
2. in name box rename to person1
3. repeat for the other 4 people (renaming to: person2 person3 person4 person5)

Attach VBA to Buttons

5 buttons: start button and 4 arrow buttons. To attach vba to them:

Start Button

1. right click button Start
2. select ‘assign macro’
3. select ‘RecolateTOPLEFT’
4. select ‘OK’

Up Arrow Button

1. right click up arrow button
2. select ‘assign macro’
3. select ‘DinoGOUP‘
4. select ‘OK’

Repeat for the other 3 arrows (DinoGORIGHT, DinoGODOWN, DinoGOLEFT).

Moving The Dinosaur

You should now be able to use the 4 arrow buttons to move the dinosaur.

Eating Humans

It’s finnicky but moving right towards the head level of a person makes him/her disappear. The bottom right has click and chomp counts.

Restart

Click ‘Start’ to reset everything. Before you move the dinosaur you can reposition the people. Clicking any arrow button will redefine the positions.

VBA Code & Formulas

I tinker with VBA (I’m not a professional programmer). I figure out what I want to do and if I can’t write the code I google it and modify it. This file works based on the interaction between vba code and formulas.

Easier to examine the code in the file but here’s the code:

a_DinoMoves

Sub RelocateTOPLEFT()
  ActiveSheet.Shapes("Dino1").Left = 15
  ActiveSheet.Shapes("Dino1").Top = 18
  Range("ChompCount").Value = 0
  
  Call ResetClickCount
  Call DinoGetLocation
  Call UnHidePersons
  Call GetLocationPerson1
  Call GetLocationPerson2
  Call GetLocationPerson3
  Call GetLocationPerson4
  Call GetLocationPerson5
End Sub

Sub DinoGORIGHT()
Application.ScreenUpdating = False
  'add to count
  Call AddToCount
  
  'make Dino face right
  Call DinoLOOKRIGHT
  
  'get Dino's location & assign to cells
  Call DinoGetLocation
  
  'move Dino right
  ActiveSheet.Shapes("Dino1").IncrementLeft 15
  
  'check if close enough to hide a person
  'Call HidePersons
  Call HidePersons
Application.ScreenUpdating = True
End Sub

Sub DinoGOLEFT()
Application.ScreenUpdating = False
  'add to count
  Call AddToCount
  
  Call DinoLOOKLEFT
  Call DinoGetLocation
  ActiveSheet.Shapes("Dino1").IncrementLeft -15
  Call HidePersons
Application.ScreenUpdating = True
End Sub

Sub DinoGOUP()
Application.ScreenUpdating = False
  'add to count
  Call AddToCount
  Call DinoLookForward
  Call DinoGetLocation
  ActiveSheet.Shapes("Dino1").IncrementTop -15
  Call HidePersons
Application.ScreenUpdating = True
End Sub

Sub DinoGODOWN()
Application.ScreenUpdating = False
  'add to count
  Call AddToCount
  Call DinoLookForward
  Call DinoGetLocation
  ActiveSheet.Shapes("Dino1").IncrementTop 15
  Call HidePersons
Application.ScreenUpdating = True
End Sub

b_DinoFaceTowards

This turns the dinosaur to face the direction it will move.

Sub DinoLookForward()
  ActiveSheet.Shapes("Dino1").Model3D.RotationX = 355
  ActiveSheet.Shapes("Dino1").Model3D.RotationY = 2.3
  ActiveSheet.Shapes("Dino1").Model3D.RotationZ = 360
End Sub

Sub DinoLOOKRIGHT()
  'change direction Dino looks (not moves)
  ActiveSheet.Shapes("Dino1").Model3D.RotationX = 8
  ActiveSheet.Shapes("Dino1").Model3D.RotationY = 53
  ActiveSheet.Shapes("Dino1").Model3D.RotationZ = 7
End Sub

Sub DinoLOOKLEFT()
  ActiveSheet.Shapes("Dino1").Model3D.RotationX = 214
  ActiveSheet.Shapes("Dino1").Model3D.RotationY = 277
  ActiveSheet.Shapes("Dino1").Model3D.RotationZ = 146
End Sub

c_GetLocations

This reads the location of the objects and writes the positions (Left, Top, Height, Width) to column C. I could’ve used a loop but I ran out of energy and repeated the code for each different object.

Sub DinoGetLocation()
  'used for: DinoGORIGHT sub
  Dim wks As Worksheet
  Dim Xpos As Double, Ypos As Double, Width As Double, Hpos As Double
  'get Dino's position
  Set wks = Sheets("dino")
  Xpos = wks.Shapes("Dino1").Left
  Ypos = wks.Shapes("Dino1").Top
  Hpos = wks.Shapes("Dino1").Height
  Width = wks.Shapes("Dino1").Width
  'assign position values to cells
  Range("C12").Value = Round(Xpos, 3)
  Range("C13").Value = Round(Ypos, 3)
  Range("C14").Value = Round(Hpos, 3)
  Range("C15").Value = Round(Width, 3)
End Sub

Sub GetLocationPerson1()
  Dim wks As Worksheet, id As String
  Dim Xpos As Double, Ypos As Double, Width As Double, Hpos As Double
  
  id = "1"
  Set wks = Sheets("dino")
  Xpos = wks.Shapes("Person" & id).Left
  Ypos = wks.Shapes("Person" & id).Top
  Hpos = wks.Shapes("Person" & id).Height
  Width = wks.Shapes("Person" & id).Width

  Range("C16").Value = Round(Xpos, 3)
  Range("C17").Value = Round(Ypos, 3)
  Range("C18").Value = Round(Hpos, 3)
  Range("C19").Value = Round(Width, 3)
End Sub

Sub GetLocationPerson2()
  Dim wks As Worksheet, id As String
  Dim Xpos As Double, Ypos As Double, Width As Double, Hpos As Double
  
  id = "2"
  Set wks = Sheets("dino")
  Xpos = wks.Shapes("Person" & id).Left
  Ypos = wks.Shapes("Person" & id).Top
  Hpos = wks.Shapes("Person" & id).Height
  Width = wks.Shapes("Person" & id).Width

  Range("C20").Value = Round(Xpos, 3)
  Range("C21").Value = Round(Ypos, 3)
  Range("C22").Value = Round(Hpos, 3)
  Range("C23").Value = Round(Width, 3)
End Sub

Sub GetLocationPerson3()
  Dim wks As Worksheet, id As String
  Dim Xpos As Double, Ypos As Double, Width As Double, Hpos As Double
  
  id = "3"
  Set wks = Sheets("dino")
  Xpos = wks.Shapes("Person" & id).Left
  Ypos = wks.Shapes("Person" & id).Top
  Hpos = wks.Shapes("Person" & id).Height
  Width = wks.Shapes("Person" & id).Width

  Range("C24").Value = Round(Xpos, 3)
  Range("C25").Value = Round(Ypos, 3)
  Range("C26").Value = Round(Hpos, 3)
  Range("C27").Value = Round(Width, 3)
End Sub

Sub GetLocationPerson4()
  Dim wks As Worksheet, id As String
  Dim Xpos As Double, Ypos As Double, Width As Double, Hpos As Double
  
  id = "4"
  Set wks = Sheets("dino")
  Xpos = wks.Shapes("Person" & id).Left
  Ypos = wks.Shapes("Person" & id).Top
  Hpos = wks.Shapes("Person" & id).Height
  Width = wks.Shapes("Person" & id).Width

  Range("C28").Value = Round(Xpos, 3)
  Range("C29").Value = Round(Ypos, 3)
  Range("C30").Value = Round(Hpos, 3)
  Range("C31").Value = Round(Width, 3)
End Sub

Sub GetLocationPerson5()
  Dim wks As Worksheet, id As String
  Dim Xpos As Double, Ypos As Double, Width As Double, Hpos As Double
  
  id = "5"
  Set wks = Sheets("dino")
  Xpos = wks.Shapes("Person" & id).Left
  Ypos = wks.Shapes("Person" & id).Top
  Hpos = wks.Shapes("Person" & id).Height
  Width = wks.Shapes("Person" & id).Width

  Range("C32").Value = Round(Xpos, 3)
  Range("C33").Value = Round(Ypos, 3)
  Range("C34").Value = Round(Hpos, 3)
  Range("C35").Value = Round(Width, 3)
End Sub

d_HideUnhidePeople

Procedures UnHidePersons & HidePersonsX loop but procedure HidePersons doesn’t (various If…End If statements check named ranges to see if Dino is close enough to each person to eat them).

Sub HidePersons()

  If Range("person1hide").Value = "Yes" Then
  ActiveSheet.Shapes.Range(Array("person1")).Visible = msoFalse
  End If

  If Range("person2hide").Value = "Yes" Then
  ActiveSheet.Shapes.Range(Array("person2")).Visible = msoFalse
  End If
  
  If Range("person3hide").Value = "Yes" Then
  ActiveSheet.Shapes.Range(Array("person3")).Visible = msoFalse
  End If
  
  If Range("person4hide").Value = "Yes" Then
  ActiveSheet.Shapes.Range(Array("person4")).Visible = msoFalse
  End If
  
  If Range("person5hide").Value = "Yes" Then
  ActiveSheet.Shapes.Range(Array("person5")).Visible = msoFalse
  End If
    
  Dim xobj As Shape
  Range("ChompCount").Value = 0
  For Each xobj In ActiveSheet.Shapes
  If xobj.Visible = False Then Range("ChompCount").Value = Range("ChompCount").Value + 1
  Next
    
End Sub

Sub UnHidePersons()
  Dim sObject As Shape
  For Each sObject In ActiveSheet.Shapes
  sObject.Visible = True
  Next
End Sub

Sub HidePersonsX()
  'if dino touches person then hide
  
  For x = 1 To 5
      If Range("person1hide" & x).Value = "Yes" Then
      ActiveSheet.Shapes.Range(Array("person" & x)).Visible = msoFalse
      Call AddToChompCount
      End If
  Next x

End Sub

e_ClickCount

Simple procedures to increase or clear the counts.

Sub AddToCount()
Range("ClickCount").Value = Range("ClickCount") + 1
End Sub

Sub ResetClickCount()
Range("ClickCount").Value = 0
End Sub

Sub AddToChompCount()
Range("ChompCount").Value = Range("ChompCount") + 1
End Sub

Recap

I got stuck several times while building this but somehow finished it. There is a better way to determine if two objects overlap but the code was too complex for me. I found an alternative way to do it by writing each object’s position into cells, using formulas to calculate proximity, and finally reading the named range (eg person1hide) ‘Yes’ or ‘No’ values back into the code (sub HidePersons).

A nice thing about a personal blog…I can decide what to play around with. There’s no commercial use for this post but I was able to practice VBA. I often watch an NBA game or listen to a podcast in Spanish while a play around in Excel. It works to forget about what’s happening these days.

About Me

I drew this a few years ago. Kind of funny, kind of lame. Anyway, my name is Kevin Lehrbass. I’m a Data Analyst and major Excel fan. I often get curious about whether or not something is possible in Excel and spend hours working on it. I always learn a lot.