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 

sample data:

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

needs to become this:

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

回答1:

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

Now we run this code

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 

Output

回答2:

You can use Power Query. Your comment led me to do some testing, and that can be done while recording a macro. For example, assuming your data is in a "table":

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 

If your user adds data, and needs to refresh the query, Data RibbonConnection tabRefresh (or you could create a button to do that if you prefer).

The unknown is how it will work on a DB of your size.

-- Before

-- After

文章来源: VBA error: not enough memory for the operation