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

您可以使用电源查询。你的评论让我做了一些测试，而这可以在录制宏时完成。例如，假设你的数据是在“表”：

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（或者你可以创建一个按钮来做到这一点，如果你喜欢）。

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

-

前 -