VBA create atom "Value out of range"

[Kaps_mr2]

Hi,

I have inherited some rather old vba code that creates circular (atoms) on an excel sheet. For some reason the code crashes with an error on the line underlined in red. The error produced is "Run time error -2147024809 (80070057) out of range". can anybody explain why ? I'm using Excel 2016. Thank you.

kind regards

' Create new collate shape
    ActiveSheet.Shapes.AddShape(msoShapeFlowchartCollate, 430, 50, 33.75, 36#).Select
    tcollate = Selection.Name
    
    ' Make Collate shape invisible
    ActiveSheet.Shapes(tcollate).Select
    
    Selection.ShapeRange.Line.Transparency = 0#
    Selection.ShapeRange.Line.Visible = msoFalse
    
    Selection.ShapeRange.Fill.Visible = msoFalse
    Selection.ShapeRange.Fill.Transparency = 0#
        
    'create new blob
    ActiveSheet.Shapes.AddShape(msoShapeOval, 430, 50, 57.75, 53.25).Select
    tblob = Selection.Name
    
    ' Put in formula to echo cell contents
    ActiveSheet.Shapes(tblob).Select
    Selection.Formula = tcell
    With Selection
        .HorizontalAlignment = xlCenter
    End With
    With Selection.Font
        .Name = "Arial"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Bold = True
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With

    ' Bring Blob forward & Handle to front
    Selection.ShapeRange.ZOrder msoBringForward
    
    ' Select new blob and new collate and new handle
    ActiveSheet.Shapes.Range(Array(tcollate, tblob)).Select
    
    'Align centres
    [COLOR=#ff0000][B][U]Selection.ShapeRange.Align msoAlignCenters, False[/U][/B][/COLOR]
    Selection.ShapeRange.Align msoAlignMiddles, False
           
    ' Group & lock new atom
    ActiveSheet.Shapes.Range(Array(tblob, tcollate)).Select
    Selection.ShapeRange.Group.Select
    Selection.ShapeRange.LockAspectRatio = msoTrue
    With Selection
        .Placement = xlFreeFloating
        .PrintObject = True
    End With
        
    Selection.Locked = False

    ' Name Atom Group and Name details cell after group name
    tatomname = "Atom" & Mid(Selection.Name, 7)
    Selection.Name = tatomname

    Range(tcell).Select
    Selection.Name = tatomname & "Details"
    
    ActiveSheet.Shapes.Range(tatomname).Select

Quit:
    ActiveSheet.Protect
    Application.ScreenUpdating = True
    
End S

 

[Worf]

Hi

Go to a new sheet and try the code below; I made minor modifications for testing purposes.

Sub atom()
Dim tcollate$, tblob$, tcell$, tatomname$, clt As Shape, blob As Shape, bplus As ShapeRange
ActiveSheet.Unprotect
Set clt = ActiveSheet.Shapes.AddShape(msoShapeFlowchartCollate, 430, 50, 34, 36)
tcollate = clt.Name
clt.Line.Transparency = 0.5
clt.Line.Visible = msoFalse
clt.Fill.Visible = msoTrue
clt.Fill.ForeColor.RGB = RGB(210, 120, 60)
clt.Fill.Transparency = 0.5
Set blob = ActiveSheet.Shapes.AddShape(msoShapeOval, 430, 50, 57.75, 53.25)
tblob = blob.Name
tcell = "k28"
blob.DrawingObject.Formula = tcell
blob.Fill.Transparency = 0.7
blob.TextFrame.HorizontalAlignment = xlHAlignCenter
With blob.DrawingObject.Font
    .Name = "Arial"
    .Size = 8
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Bold = True
    .Underline = xlUnderlineStyleNone
    .ColorIndex = xlAutomatic
End With
blob.ZOrder msoBringForward ' Bring Blob forward & Handle to front
' Select new blob and new collate and new handle
Set bplus = ActiveSheet.Shapes.Range(Array(tcollate, tblob))
bplus.Align msoAlignCenters, False
bplus.Align msoAlignMiddles, False
bplus.Group.Select                  ' Group & lock new atom
bplus.LockAspectRatio = msoTrue
With Selection
    .Placement = xlFreeFloating
    .PrintObject = True
    .Locked = False
End With
' Name Atom Group and Name details cell after group name
tatomname = "Atom" & Mid(Selection.Name, 7)
Selection.Name = tatomname
Range(tcell).Activate
Selection.Name = tatomname & "Details"
ActiveSheet.Shapes.Range(tatomname).Select
Quit:
ActiveSheet.Protect
Application.ScreenUpdating = True
End Sub