VBA error: not enough memory for the operation

Question

This script is giving me an error because it consumes too much resources. What can I do to fix that?

Dim oSht As Worksheet
Dim i As Long, j As Integer
Dim LRow As Long, LCol As Long
Dim Email1Col As Integer, Email2Col As Integer, Email3Col As Integer
Dim arr As Variant
Dim SplEmail3 As String


'Definitions
Set oSht = ActiveSheet
Email1Col = 6
Email2Col = 7
Email3Col = 8
'-----------

With oSht
'LRow = .Range("G" & .Rows.Count).End(xlUp).Row
LRow = 1048576
'LCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With

For i = 2 To LRow
    'If oSht.Rows(i + 1).EntireRow = 0 Then GoTo Skip
    If Cells(i, Email1Col).Value <> "" Or Cells(i, Email3Col).Value <> "" Then
        If Cells(i, Email2Col) <> "" Then
            'email2 to new row + copy other data
            Rows(i + 1).EntireRow.Insert
            oSht.Rows(i + 1).EntireRow.Value = oSht.Rows(i).EntireRow.Value
            Range(Cells(i + 1, Email1Col), Cells(i + 1, Email3Col)).ClearContents
            Cells(i + 1, Email1Col) = Cells(i, Email2Col)
            'email3 to new row + copy other data
        End If
        If Cells(i, Email3Col) <> "" Then
            arr = Split(Cells(i, Email3Col), ",", , 1)
            For j = 0 To UBound(arr)
                'split into single emails
                SplEmail3 = Replace((arr(j)), " ", "", 1, , 1)
                'repeat the process for every split
                Rows(i + 2 + j).EntireRow.Insert
                oSht.Rows(i + 2 + j).EntireRow.Value = oSht.Rows(i).EntireRow.Value
                Range(Cells(i + 2 + j, Email1Col), Cells(i + 2 + j, Email3Col)).ClearContents
                Cells(i + 2 + j, Email1Col) = SplEmail3
            Next j
        End If
        Range(Cells(i, Email2Col), Cells(i, Email3Col)).ClearContents
    Else
        Rows(i).EntireRow.Delete
    End If
Skip:
Next i

sample data:

col1, col2,..., col6, col7 ,  col8
name, bla, ...,mail1,mail2,(mail3,mail4,mail5)

needs to become this:

col1, col2,..., col6
name, bla, ...,mail1

Answer 1

Note: I have tested this with very small piece of data.. Give it a try and if you are stuck then let me know. We will take it from there.

Let's say our data looks like this

Now we run this code

Sub Sample()
    Dim oSht As Worksheet
    Dim arr As Variant, FinalArr() As String
    Dim i As Long, j As Long, k As Long, LRow As Long

    Set oSht = ActiveSheet

    With oSht
        LRow = .Range("A" & .Rows.Count).End(xlUp).Row

        arr = .Range("A2:H" & LRow).Value

        i = Application.WorksheetFunction.CountA(.Range("G:H"))

        '~~> Defining the final output array
        ReDim Preserve FinalArr(1 To (LRow + i - 3), 1 To 6)

        k = 0
        For i = LBound(arr) To UBound(arr)
            k = k + 1
            FinalArr(k, 1) = arr(i, 1)
            FinalArr(k, 2) = arr(i, 2)
            FinalArr(k, 3) = arr(i, 3)
            FinalArr(k, 4) = arr(i, 4)
            FinalArr(k, 5) = arr(i, 5)
            If arr(i, 6) <> "" Then FinalArr(k, 6) = arr(i, 6)

            For j = 7 To 8
                If arr(i, j) <> "" Then
                    k = k + 1
                    FinalArr(k, 1) = arr(i, 1)
                    FinalArr(k, 2) = arr(i, 2)
                    FinalArr(k, 3) = arr(i, 3)
                    FinalArr(k, 4) = arr(i, 4)
                    FinalArr(k, 5) = arr(i, 5)
                    FinalArr(k, 6) = arr(i, j)
                End If
            Next j
        Next i

        .Rows("2:" & .Rows.Count).Clear

        .Range("A2").Resize(UBound(FinalArr), 6).Value = FinalArr
    End With
End Sub

Output