过滤OLAP多维数据集时出现内存问题

Question

因此，我有一个宏，对于初学者而言，它需要打开一个文件并用一些日期过滤OLAP多维数据集。执行此操作会消耗大量内存，从100Mb到1,5Gb。

这是一个问题，因为稍后我将在类中填充很多数据，并且可能会引发内存不足错误。

事实是，我似乎无法以任何方式清除内存，因为它没有因为某些存储对象而占用那堆内存，只是因为它正在过滤多维数据集。

有人解决这个问题吗？我尝试保存工作簿，即使停止宏并保存工作簿也无法解决此问题。

主子：

Option Explicit
Sub Main()

    Dim MisDatos As New España

    MisDatos.CargaReales


End Sub

从事这项工作的班级：

Option Explicit
Private m_Login As Object
Property Get Logins(ByVal Key As String) As Logins
    With m_Login
        If Not .Exists(Key) Then .Add Key, New Logins
    End With
    Set Logins = m_Login(Key)
End Property
Private Sub Class_Initialize()
    Set m_Login = CreateObject("Scripting.Dictionary")
End Sub
Private Sub Class_Terminate()
    Set m_Login = Nothing
End Sub
Public Property Get Keys() As Variant
    Keys = m_Login.Keys
End Property
Public Property Get Count() As Long
    Count = m_Login.Count
End Property
Public Sub CargaReales()

    Dim wb As Workbook
    Set wb = Workbooks.Open("C:\Users\USER\Desktop\Adherencia\España\BI KronosReporting.xlsb", False, True)

    Dim ArrayFechasFiltrado As Variant
    ArrayFechasFiltrado = CargaFechasFiltrado
    FiltrarTablaReales wb, ArrayFechasFiltrado
    Erase ArrayFechasFiltrado

    Dim arrReales As Variant
    arrReales = wb.Sheets(1).UsedRange.Value
    wb.Close False
    Set wb = Nothing

End Sub
Private Function CargaFechasFiltrado() As Variant

    Dim Festivos As Object
    Set Festivos = CargaFestivos

    'Vamos a cargar las fechas que necesitaremos para cargar los fichajes en un array
    With ThisWorkbook.Sheets("Main")

        Dim FechaI As Date
        FechaI = Left(.Cells(1, 2), 10) 'Fecha Inicio

        Dim FechaF As Date
        FechaF = Right(.Cells(1, 2), 10) 'Fecha Fin

        ReDim arr(Day(FechaI) To Day(FechaF) - Festivos.Count) As String 'Declaramos un array del tamaño de los días necesarios

        Dim Fecha As Date
        Dim i As Long
        Dim x As Long: x = Day(FechaI)
        For i = Day(FechaI) To Day(FechaF) 'hacemos un bucle para meter dichos días en el array
            Fecha = DateSerial(Year(FechaI), Month(FechaI), i)
            If Not Festivos.Exists(Fecha) Then
                arr(x) = "[Fecha Trabajo].[Fecha Trabajo].[Día del Mes].&[" & Format(Fecha, "yyyymmdd") & "]"
                x = x + 1
            End If
        Next i
    End With

    CargaFechasFiltrado = arr

End Function
Private Function CargaFestivos() As Object

    'Cargamos los festivos en un diccionario
    Dim Diccionario As Object: Set Diccionario = CreateObject("Scripting.Dictionary")
    With ThisWorkbook.Sheets("Main")
        Dim lrow As Long
        lrow = .Cells(.Rows.Count, "D").End(xlUp).Row
        If lrow > 2 Then
            Dim i As Long
            For i = 3 To lrow
                Diccionario.Add .Cells(i, 4).Value, 1
            Next i
            Set CargaFestivos = Diccionario
        Else
            Set CargaFestivos = Nothing
        End If
    End With

End Function
Private Sub FiltrarTablaReales(wb As Workbook, arr As Variant)

    wb.SlicerCaches("SegmentaciónDeDatos_Fecha_Trabajo.Fecha_Trabajo").VisibleSlicerItemsList = arr

End Sub

这是最后一个子，FiltrarTablaReales正在填充内存。如您所见，没有任何对象，但是以后清空了一个数组（它不能消耗那么多的内存，因为最大为1到31）。

有什么想法吗？

Answer 1

不需要访问工作簿的次数很多。我会尝试将工作表移动到数组中，然后再将其放入数组中。

Private Function CargaFestivos() As Object

    'Cargamos los festivos en un diccionario
    Dim Diccionario As Object: Set Diccionario = CreateObject("Scripting.Dictionary")
    With ThisWorkbook.Sheets("Main")
        Dim lrow As Long
        lrow = .Cells(.Rows.Count, "D").End(xlUp).Row
        If lrow > 2 Then
            Dim i As Long
'change here
            dim myArr as variant
            redim myArr(1 to lrow, 1 to 1)
            myArr=.cells(1,4).resize(lrow).value
            For i = 3 To lrow
                Diccionario.Add myArr(i,1), 1 'get it to use the array instead
'end of changes
            Next i
            Set CargaFestivos = Diccionario
        Else
            Set CargaFestivos = Nothing
        End If
    End With

End Function