VBA-Fehler: Nicht genügend Speicher für die Operation

Question

Dieses Skript gibt mir einen Fehler, weil es zu viele Ressourcen verbraucht. Was kann ich tun, um das zu beheben?

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 

Beispieldaten:

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

Bedürfnisse dies werden:

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

Answer 1

Hinweis: Ich habe dies von Daten mit sehr kleinen Stück getestet .. Probieren Sie es aus und Wenn Sie stecken bleiben, lassen Sie es mich wissen. Wir werden es von dort nehmen.

Sagen wir unsere Daten nun wie folgt

sieht führen wir diesen 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 

Ausgabe

Answer 2

können Sie verwenden Energieanfrage. Dein Kommentar hat mich dazu gebracht, einige Tests durchzuführen, und das kann während der Aufzeichnung eines Makros erfolgen. Zum Beispiel ist in einer „Tabelle“ Ihre Daten unter der Annahme:

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 

Wenn Ihre Benutzerdaten hinzufügt, und muss die Abfrage aktualisieren, Data Ribbon ► Connection tab ► Refresh (oder Sie können eine Schaltfläche erstellen, das zu tun, wenn Sie bevorzugen).

Das Unbekannte ist, wie es auf einem DB Ihrer Größe funktioniert.

- Vor

- Nach