Macro that randomly selects from a list and populates a shape with the selected item

[glad_ir]

Hello,

Hoping somebody can help me with this one please.

I'd like to create a shape in excel that when "clicked" populates itself with a word selected randomly from a list. I know how to link shapes to a macro but the coding for the macro is beyond me.

Any help is much appreciated!

Thanks,
Iain

 

[DanteAmor]

Adjust the data in blue by your values:

Sub shape_randomly_word()
  Dim shp As Shape
  Dim arr As Variant
  Dim n As Long
  
  Set shp = ActiveSheet.Shapes("shape1")
  
  Randomize
  arr = Range("A2:A10").Value
  n = WorksheetFunction.RandBetween(LBound(arr), UBound(arr))
  shp.TextFrame2.TextRange.Characters.Text = arr(n, 1)
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------

 

[Trebor76]

I've made a number of assumptions but try this:

Option Explicit
Sub Macro1()

    Dim wsShapeTab As Worksheet, wsWordsTab As Worksheet
    Dim strSrcCol As String
    Dim lngLastRow As Long, lngSrcRow As Long
    
    Application.ScreenUpdating = False
    
    Set wsShapeTab = ThisWorkbook.Sheets("Sheet1") '<-Sheet name containing the shape. Change to suit.
    Set wsWordsTab = ThisWorkbook.Sheets("Sheet2") '<-Sheet name containing the word list. Change to suit.
    strSrcCol = "A" '<-Source column containing the word list in 'wsWordTab'. Change to suit.
    lngLastRow = wsWordsTab.Cells(Rows.Count, strSrcCol).End(xlUp).Row
    lngSrcRow = WorksheetFunction.RandBetween(2, lngLastRow) '<-Assumes the start row number for the word list is Row 2. Change to suit.
    'Link a shape called 'Rectangle 1' (change to suit) on 'wsShapeTab'
    wsShapeTab.Shapes("Rectangle 1").OLEFormat.Object.Formula = "='" & wsWordsTab.Name & "'!" & strSrcCol & lngSrcRow 'https://www.mrexcel.com/board/threads/use-vba-to-add-reference-to-cell-in-a-shape-like-a-textbox.645447
    
    Application.ScreenUpdating = True
    
End Sub

Regards,

Robert

 

[glad_ir]

Adjust the data in blue by your values:

Sub shape_randomly_word()
  Dim shp As Shape
  Dim arr As Variant
  Dim n As Long
 
  Set shp = ActiveSheet.Shapes("shape1")
 
  Randomize
  arr = Range("A2:A10").Value
  n = WorksheetFunction.RandBetween(LBound(arr), UBound(arr))
  shp.TextFrame2.TextRange.Characters.Text = arr(n, 1)
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------

Hi Dante - this works a treat. Thank you! Can I ask a follow up question please. My A2:A10 entries consist of just "positive" and "negative" - I'm using 9 cells rather than 2 so I can bias the probability. Is it possible to change the colour of shape 1 based on the randomly selected word - e.g. if "negative" is selected shape 1 is coloured green and if "positive" is returned shape 1 is coloured red? Thank you for your help so far and any more you can offer!

 

[DanteAmor]

if "negative" is selected shape 1 is coloured green and if "positive" is returned shape 1 is coloured red

Try:

Sub shape_randomly_word()
  Dim shp As Shape
  Dim arr As Variant
  Dim n As Long
  
  Set shp = ActiveSheet.Shapes("shape1")
  
  Randomize
  arr = Range("A2:A10").Value
  n = WorksheetFunction.RandBetween(LBound(arr), UBound(arr))
  shp.TextFrame2.TextRange.Characters.Text = arr(n, 1)
  If LCase(arr(n, 1)) = LCase("negative") Then
    shp.Fill.ForeColor.RGB = RGB(0, 255, 0)
  ElseIf LCase(arr(n, 1)) = LCase("positive") Then
    shp.Fill.ForeColor.RGB = RGB(255, 0, 0)
  End If
End Sub

 

[glad_ir]

Try:

Sub shape_randomly_word()
  Dim shp As Shape
  Dim arr As Variant
  Dim n As Long
 
  Set shp = ActiveSheet.Shapes("shape1")
 
  Randomize
  arr = Range("A2:A10").Value
  n = WorksheetFunction.RandBetween(LBound(arr), UBound(arr))
  shp.TextFrame2.TextRange.Characters.Text = arr(n, 1)
  If LCase(arr(n, 1)) = LCase("negative") Then
    shp.Fill.ForeColor.RGB = RGB(0, 255, 0)
  ElseIf LCase(arr(n, 1)) = LCase("positive") Then
    shp.Fill.ForeColor.RGB = RGB(255, 0, 0)
  End If
End Sub

Hi,

Thank you for this. The code colours the shape green irrespective of the outcome. Does the second RGB code need to be different?

Thanks again!

 

[DanteAmor]

  If LCase(arr(n, 1)) = LCase("negative") Then
    shp.Fill.ForeColor.RGB = RGB(0, 255, 0)
  ElseIf LCase(arr(n, 1)) = LCase("positive") Then
    shp.Fill.ForeColor.RGB = RGB(255, 0, 0)
  End If

They are different RGB

The texts in the cells must be "positive" and "negative" check that the texts are indeed well written.
Check that there are no blank spaces before or after the text.

 

[glad_ir]

Hi,

Thank you for this. The code colours the shape green irrespective of the outcome. Does the second RGB code need to be different?

Thanks again!

  If LCase(arr(n, 1)) = LCase("negative") Then
    shp.Fill.ForeColor.RGB = RGB(0, 255, 0)
  ElseIf LCase(arr(n, 1)) = LCase("positive") Then
    shp.Fill.ForeColor.RGB = RGB(255, 0, 0)
  End If

They are different RGB

The texts in the cells must be "positive" and "negative" check that the texts are indeed well written.
Check that there are no blank spaces before or after the text.

Apologies. Your code is perfect....I had capitalised the P and N for positive and negative in my list. Thanks again for your help - much appreciated!

 

[DanteAmor]

I had capitalised the P and N for positive and negative in my list

The macro works if you have "positive", "Positive", "POSITIVE", it is set to not be case sensitive, you must have another character that is not in the cells, but if it already works for you, I am happy.