Memory Leak when expanding data from worksheet to worksheet

[cutie]

Hi,

I am encoutering "Out of Memory" error when running my macro, i have zoom down to this sub that make the memory usage increase from 100,000k to over 500,000k until the error hit

This sub will take around 5k data and expand to more than 150k data in another sheet. The funny thing is when debugging, the memory won't increase but when let it run continuosly, it increase tremendously.

Any advise to improve this code further to prevent memory leak?
Please help.
Thanks in advance.

Sub MapSourceWithData()
    Dim destWs As Worksheet
    Dim vSrcData As Variant
    Dim rData As Range
    Dim rDataFiltered As Range
    Dim vaMappedData() As Variant
    Dim vaOutput() As Variant
    Dim c As Variant
    Dim newRow As Long
    Dim colLen As Long
    
    Dim i As Long
    Dim j As Long
    Dim colDex As Long
    Dim rowMaxCount As Integer
        
    Dim isSuccess As Boolean
    
    'Set MyTimer = New CTimer
    'MyTimer.StartCounter
    
    rowMaxCount = 1
    newRow = 1
    
    vSrcData = Sheets("ProductionMBOMData").UsedRange.Value
    Set rData = Sheets("SpecialNotes").UsedRange
    
    colLen = UBound(vSrcData, 2) + 1
    
    'Prepare for autofilter
    rData.Columns("A:C").EntireColumn.Hidden = True
    rData.Columns("E:F").EntireColumn.Hidden = True
    rData.Rows("1:1").EntireRow.Hidden = True
        
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
     
    'Set Header for new sheet
    'If sheet not exists, create
    If Not IsSheetExists("SrcWithSteps") Then
        With Worksheets.Add(After:=Sheets(Sheets.Count))
            .Name = "SrcWithSteps"
        End With
    Else
        Sheets("SrcWithSteps").Cells.Clear
    End If
    
    Set destWs = Sheets("SrcWithSteps")
    For colDex = 1 To colLen - 1
        destWs.Cells(1, colDex).Value = vSrcData(1, colDex)
    Next colDex
    destWs.Cells(1, colLen).Value = "STEPCODE"
    
    ReDim Preserve vaMappedData(1 To colLen, 1 To rowMaxOutput)
    
    'Start from 2 to skip header
    For i = 2 To UBound(vSrcData, 1)
         rData.AutoFilter Field:=1, Criteria1:=vSrcData(i, 11)
        On Error Resume Next
        Set rDataFiltered = rData.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not rDataFiltered Is Nothing Then
            For Each c In rDataFiltered
                'vaMappedData = array(col, row), have to transpose before output to sheet
                If rowMaxCount > rowMaxOutput Then
                    isSuccess = TransposeArray(vaMappedData, vaOutput)
                    If isSuccess Then
                        destWs.Range("A" & (2 + newRow - rowMaxCount)).Resize(UBound(vaOutput, 1), UBound(vaOutput, 2)).Value = vaOutput
                    End If
                    Erase vaOutput
                    ReDim vaMappedData(1 To colLen, 1 To rowMaxOutput)
                    rowMaxCount = 1
                End If
                'copy all data in Src
                For colDex = 1 To colLen - 1
                    vaMappedData(colDex, rowMaxCount) = vSrcData(i, colDex)
                Next colDex
                vaMappedData(colLen, rowMaxCount) = c.Value
                newRow = newRow + 1
                rowMaxCount = rowMaxCount + 1
            Next c
        Else
            If rowMaxCount > rowMaxOutput Then
                isSuccess = TransposeArray(vaMappedData, vaOutput)
                If isSuccess Then
                    destWs.Range("A" & (2 + newRow - rowMaxCount)).Resize(UBound(vaOutput, 1), UBound(vaOutput, 2)).Value = vaOutput
                End If
                Erase vaOutput
                ReDim vaMappedData(1 To colLen, 1 To rowMaxOutput)
                rowMaxCount = 1
            End If
                
            For colDex = 1 To colLen - 1
                vaMappedData(colDex, rowMaxCount) = vSrcData(i, colDex)
            Next colDex
            vaMappedData(colLen, rowMaxCount) = "NOT FOUND"
            newRow = newRow + 1
            rowMaxCount = rowMaxCount + 1
        End If
        Set rDataFiltered = Nothing
    Next i
    'vaMappedData = array(row, col), transposing before output to sheet
    isSuccess = TransposeArray(vaMappedData, vaOutput)
        
    'Reset autofilter
    rData.AutoFilter
    rData.Columns("A:C").EntireColumn.Hidden = False
    rData.Columns("E:F").EntireColumn.Hidden = False
    rData.Rows("1:1").EntireRow.Hidden = False
    Sheets("Main").Range("C23").Value = MyTimer.TimeElapsed
    'Check Data
    destWs.Range("A" & (2 + newRow - rowMaxCount)).Resize(UBound(vaOutput, 1), UBound(vaOutput, 2)).Value = vaOutput
    Set rData = Nothing
    Set rDataFiltered = Nothing
    Erase vSrcData
    Erase vaMappedData
    Erase vaOutput
    Erase c
    
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
    
End Sub

 

[Andrew Poulsom]

What are rowMaxOutput, TransposeArray and MyTimer?

 

[cutie]

What are rowMaxOutput, TransposeArray and MyTimer?

rowMaxOutput is a global constant indicating how many rows will be process before output to worksheet, then restart at 0 again.

Public Const rowMaxOutput As Integer = 10000

TransposeArray is a function to change the row, column of the array

MyTimer is a performance counter, indicating the process time used for the function.

Both function is source from internet. Do let me know if u need the code.