VBA错误: not enough memory for the operation

Question

这个脚本给我一个错误，因为它消耗了太多的资源。我可以做什么来解决这个问题？

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

Answer 1

注意:我已经用非常小的数据对此进行了测试。尝试一下，如果您遇到困难，请告诉我。我们将从那里拿走它。

假设我们的数据如下所示

现在我们运行这段代码

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

输出