Memory error/ crash and restart

[Gethsaine]

Hi All.

A while ago I posted about option buttons on a spreadsheet that I've got, and the help I got here was second to none so thanks for that.

My new query concerns the same spreadsheet I've been trying to split the sheet into three smaller spreadsheets (for printing and ease of use purposes), but as I get to the point of adding rows in the new spreadsheet, the sheet either crashes outright and I have to restart or it throws up a runtime error saying out of memory then I have to restart from there.

I fear it may have something to do with the sheer number of option buttons that are being/ have been created by the sheet, however these buttons are integral to the sheet's use.

Is there any way around the memory issue or is my spreadsheet finally doomed?

Many thanks in advance for your help.

Within the sheet there is code for inserting a new row with a set of option buttons in each row, and a user defined formula for calculating values in bold only, the code is as follows:

Private Sub CommandButton1_Click()
   
   Dim iCurrentRow As Long
   Dim iRowOffset As Long
   Dim iRow As Long
   Dim sCell As String
   Dim sGroupName As String
   Dim x As Long
   ActiveCell.EntireRow.Select
   If vRows = 0 Then
    vRows = Application.InputBox(prompt:= _
      "How many rows do you want to add?", Title:="Add Rows", _
      Default:=1, Type:=1)
    If vRows = False Then Exit Sub
    
    'Add test for vrows > 0 and < some aribitrary max limit
    
   End If
   Dim sht As Worksheet, shts() As String, i As Long
   ReDim shts(1 To Worksheets.Application.ActiveWorkbook. _
       Windows(1).SelectedSheets.Count)
   i = 0
   For Each sht In _
       Application.ActiveWorkbook.Windows(1).SelectedSheets
    Sheets(sht.Name).Select
    i = i + 1
    shts(i) = sht.Name


    x = Sheets(sht.Name).UsedRange.Rows.Count
    
    Selection.Resize(rowsize:=2).Rows(2).EntireRow. _
     Resize(rowsize:=vRows).Insert Shift:=xlDown


    Selection.AutoFill Selection.Resize( _
     rowsize:=vRows + 1), xlFillDefault
     
    'Get the current row
    iRow = ActiveCell.Row
    
    'Put OptionButtons in column F of the following rows
    For iRowOffset = 1 To vRows
      iCurrentRow = iRow + iRowOffset
      sCell = "F" & iCurrentRow
      
      'Create a UNIQUE Group Name for the Option Buttons Based on
      'the Current Date and Time of the form ("Groupyymmddhhmmss-NNNN")
      'Where NNNN is the current row number
      sGroupName = "Group" & Format(Now(), "yymmddhhmmss") & "-" & Format(iCurrentRow, "0000")
    
      Call PutOptionButtonsInCell(sCell, sGroupName)
    Next iRowOffset
    
    On Error Resume Next
    Next
    
End Sub




Sub PutOptionButtonsInCell(sAddress As String, sGroupName As String)


    Const xHorizontalOFFSET = 6


    Dim r As Range
    Dim wbo As Workbook
    Dim wbs As Worksheet
    Dim btn As Object
    
    Dim iRow As Long
    
    Dim xLeft As Double
    Dim xTop As Double
    Dim xWidth As Double
    Dim xHeight As Double
        
    Dim xCellLeft As Double
    Dim xCellTop As Double
    Dim xCellWidth As Double
    Dim xCellHeight As Double
    
    Set r = ActiveSheet.Range(sAddress)
    iRow = r.Row
    
    xCellLeft = r.Left
    xCellTop = r.Top
    xCellWidth = r.Width
    xCellHeight = r.Height
    


    Set wbo = ActiveWorkbook
    Set wbs = wbo.ActiveSheet
 
    With ActiveSheet
    
        xLeft = xCellLeft + xHorizontalOFFSET
        xWidth = xCellWidth - xHorizontalOFFSET
        xHeight = xCellHeight / 4
        xTop = xCellTop + xHeight / 2
        Set btn = .OLEObjects.Add(ClassType:="Forms.OptionButton.1", _
                                  Link:=True, _
                                  DisplayAsIcon:=False, _
                                  Left:=xLeft, _
                                  Top:=xTop, _
                                  Width:=xWidth, _
                                  Height:=xHeight)
        btn.Object.Caption = "Credit Card"
        btn.Object.GroupName = sGroupName
        btn.LinkedCell = "J" & iRow
        btn.Object.Value = False
        btn.Object.GroupName = sGroupName
                    
                    
        xTop = xTop + xHeight
        Set btn = .OLEObjects.Add(ClassType:="Forms.OptionButton.1", _
                                  Link:=True, _
                                  DisplayAsIcon:=False, _
                                  Left:=xLeft, _
                                  Top:=xTop, _
                                  Width:=xWidth, _
                                  Height:=xHeight)
        btn.Object.Caption = "Petty Cash"
        btn.Object.GroupName = sGroupName
        btn.LinkedCell = "K" & iRow
        btn.Object.Value = False
    
        xTop = xTop + xHeight
        Set btn = .OLEObjects.Add(ClassType:="Forms.OptionButton.1", _
                                  Link:=True, _
                                  DisplayAsIcon:=False, _
                                  Left:=xLeft, _
                                  Top:=xTop, _
                                  Width:=xWidth, _
                                  Height:=xHeight)
        btn.Object.Caption = "Purchase Order"
        btn.Object.GroupName = sGroupName
        btn.LinkedCell = "L" & iRow
        btn.Object.Value = False
    End With
End Sub



Function SumIfBold(MyRange As Range) As Double


    Dim cell As Range
    For Each cell In MyRange
        If cell.Font.Bold = True Then
            SumIfBold = SumIfBold + cell
        End If
    Next cell


End Function

 

[Gethsaine]

Just an edit to this post (I can't find the edit post button, think i'm being blind)

I have tried adding new rows to the original spreadsheet and it works no problem, however once I split it down into smaller sheets, then I start to have issues. I am intending on splitting it into four sheets, the first one worked with no problems, the second one can insert a few rows with option buttons and then after about the fourth or fifth row, I get the error. The error gives me the option to debug or end, and either option gives the same result which is a crash and restart.

Thanks again.