VBA 错误：没有足够的内存用于操作

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

输出

Answer 2

您可以使用 Power Query。您的评论使我进行了一些测试，这可以在录制宏时完成。例如，假设您的数据在“表”中：

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

如果您的用户添加数据并需要刷新查询，Data Ribbon ► Connection tab ► Refresh（或者您可以创建一个按钮来执行此操作，如果您愿意）。

未知的是它将如何在您大小的数据库上工作。

-- 之前

-- 之后