VBA错误：操作的内存不足 [英] VBA error: not enough memory for the operation

问题描述

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

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

样本数据：

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

需求成为这个：

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

推荐答案

注意用非常小的数据进行测试。尝试一下，如果你被卡住，然后让我知道。我们将从那里拿走。

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

现在我们运行这段代码

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

输出

这篇关于VBA错误：操作的内存不足的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！