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（或者你可以創建一個按鈕來做到這一點，如果你喜歡）。

未知是它將如何在您的大小的數據庫上工作。

-

前 -