VBA error: not enough memory for the operation - vba

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

Answer 2

You can use Power Query. Your comment led me to do some testing, and that can be done while recording a macro. For example, assuming your data is in a "table":
Sub createPQ()
ActiveWorkbook.Queries.Add Name:="Table1", Formula:= _
"let" & Chr(13) & "" & Chr(10) & " Source = Excel.CurrentWorkbook(){[Name=""Table1""]}[Content]," & Chr(13) & "" & Chr(10) & " #""Changed Type"" = Table.TransformColumnTypes(Source,{{""FirstName"", type text}, {""LastName"", type text}, {""blah1"", type text}, {""b lah2"", type text}, {""bla3"", type text}, {""email1"", type text}, {""email2"", type text}, {""email3"", type text}})," & Chr(13) & "" & Chr(10) & " #""Unpivoted Columns"" = Tab" & _
"le.UnpivotOtherColumns(#""Changed Type"", {""FirstName"", ""LastName"", ""blah1"", ""b lah2"", ""bla3""}, ""Attribute"", ""Value"")" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & " #""Unpivoted Columns"""
Sheets.Add After:=ActiveSheet
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
"OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=Table1" _
, Destination:=Range("$A$1")).QueryTable
.CommandType = xlCmdSql
.CommandText = Array("SELECT * FROM [Table1]")
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = False
.ListObject.DisplayName = "Table1_2"
.Refresh BackgroundQuery:=False
End With
End Sub
If your user adds data, and needs to refresh the query, Data Ribbon ► Connection tab ► Refresh (or you could create a button to do that if you prefer).
The unknown is how it will work on a DB of your size.
-- Before
-- After