Maintain selected listbox items when reopening worksheet (issue)

I am working with some code below that will record listbox selections and maintain those selections when the worksheet is closed and reopened. The code is working for SOME of the listbox items, but it doesn't maintain for all of them. It seems like there are issues with one line of code, and I sometimes get errors about the OLE Object. Any assistance with modifying the below code to function properly would be much appreciated! I have also attached the sample worksheet with the listboxes and VBA code.

This code is within ThisWorkbook:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Call StoreSelections
End Sub

Private Sub Workbook_Open()
    Call RestoreSelections
End Sub

This code is within Module3:

Option Explicit

Sub RestoreSelections()
On Error Resume Next
    Dim LastRow As Long
    Dim LastColumn As Long
    Dim i As Long
    Dim j As Long

    With Worksheets("Listboxes")
        LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
        For i = 1 To LastColumn
            If .Cells(1, i).Value <> "" Then
                LastRow = .Cells(.Rows.Count, i).End(xlUp).Row
                For j = 2 To LastRow
                    Worksheets("Accounts Pivot").OLEObjects(.Cells(1, i).Value).Object.Selected(.Cells(j, i)) = True
                Next j
            End If
        Next i
    End With

End Sub

Sub StoreSelections()

    Dim OleObj As OLEObject
    Dim MyArray() As Long
    Dim NextColumn As Long
    Dim Cnt As Long
    Dim i As Long
    
    Worksheets("Listboxes").Cells.Clear

    NextColumn = 1
    For Each OleObj In Worksheets("Accounts Pivot").OLEObjects
        If TypeName(OleObj.Object) = "ListBox" Then
            With OleObj.Object
                For i = 0 To .ListCount - 1
                    If .Selected(i) Then
                        Cnt = Cnt + 1
                        ReDim Preserve MyArray(1 To Cnt)
                        MyArray(Cnt) = i
                    End If
                Next i
            End With
            If Cnt > 0 Then
                With Worksheets("Listboxes")
                    .Cells(1, NextColumn) = OleObj.Name
                    .Cells(2, NextColumn).Resize(UBound(MyArray)).Value = WorksheetFunction.Transpose(MyArray)
                End With
                NextColumn = NextColumn + 1
                Erase MyArray
                Cnt = 0
            End If
        End If
    Next OleObj
    
End Sub

This is probably the culprit of the problem, but don't know how to fix:

Worksheets("Accounts Pivot").OLEObjects(.Cells(1, i).Value).Object.Selected(.Cells(j, i)) = True

ListBox Issues Example.xlsm

Kind regards!