VBA错误：没有足够的内存进行操作

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

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

注意 ：我已经用非常小的数据testing过了。试试看，如果卡住了，就让我知道。 我们将从那里拿走。

假设我们的数据看起来像这样

现在我们运行这个代码

 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。 您的评论导致我做了一些testing，而这可以在录制macros时完成。 例如，假设你的数据在一个“表”中：

 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 （或者如果您愿意，可以创build一个button来执行此操作）。

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

– 之前

– 之后