VBA错误：操作没有足够的内存(VBA error: not enough memory for the operation)

 这个脚本给我一个错误，因为它消耗了太多的资源。 我能做些什么来解决这个问题？ 
 
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
 
 样本数据： 
 
col1, col2,..., col6, col7 ,  col8
name, bla, ...,mail1,mail2,(mail3,mail4,mail5)
 
 需要成为这样的： 
 
col1, col2,..., col6
name, bla, ...,mail1

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

原文：https://stackoverflow.com/questions/38674587