There isn't enough memory to complete this action

alantse2010

New Member
Joined
Jun 9, 2018
Messages
34
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2010
Platform
  1. Windows
Hi all,

When i press a button to run the VBA, previously it works but now shows the below message but my excel version is Microsoft 365.
1675322000591.png

1675322114264.png


The VBA show error on here but i don't know why, would anyone help me?
1675322278168.png

Thank you very much
Below is my code:

VBA Code:
Dim wb As Workbook
Dim wb2 As Workbook
Dim wb3 As Workbook
Dim wb6 As Workbook
Dim wss As Worksheet
Dim wsx As Worksheet
Dim wsw As Worksheet
Dim y As Workbook
Dim sDirectory As String
Dim sFilename As String
Dim sheet As Worksheet
Dim total As Long
Dim i As Long
Dim ii As Long
Dim lastRow, lastRow2 As Long
Dim maxRwoNo As Long
Dim sImportFile As String
Dim totalactive As Long
Dim readsheetName As String
Dim destsheetName As String
Dim DestSheet As Worksheet, Lr, Lr2 As Long
Dim SourceRange, SourceRange2, SourceRange3, SourceRange4 As Range
Dim fso As Object, FolDir As String, FileNm As Object, NumStr As Integer, MaxNum As Integer
Dim NewName As String, StrNum As String, MaxStr As String
Dim FolderStr As String 'Object
MaxNum = 1
FolderStr = "C:\SRQ VBA Test\"
FolDir = Dir(FolderStr)
MsgBox (FolDir)
readsheetName = "2011-2019"
destsheetName = "Cable Collection Advices (2)"
Set wb = ThisWorkbook
Set wsw = wb.Sheets(readsheetName)

wsw.Activate

Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Filtered Data").Delete


On Error GoTo 0
Application.DisplayAlerts = True
 Application.ScreenUpdating = False
Set wsDest = ThisWorkbook.Sheets.Add(After:= _
             ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
 wsDest.Name = "Filtered Data"
MM1
wsw.Range("A1:U1").AutoFilter Field:=7, Criteria1:="296699"
wsw.Range("A1:U1").AutoFilter Field:=14, Criteria1:="Available", Operator:=xlOr, Criteria2:="="
If wsw.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
  
  wsw.Cells.SpecialCells(xlCellTypeVisible).Copy
   wsDest.Activate
   wsDest.Range("A1").PasteSpecial xlPasteFormulasAndNumberFormats
   
   wsDest.Columns("N:U").Delete
   wsDest.Columns("A:B").Delete
   wsDest.Columns("F").Delete
   wsDest.Rows(1).Delete
    lastRow = wsDest.Range("A" & Rows.Count).End(xlUp).Row
   'SRQ C to F
   Set SourceRange = wsDest.Range("A1:D" & lastRow)
   Set SourceRange2 = wsDest.Range("F1:G" & lastRow)
   Set SourceRange3 = wsDest.Range("E1:E" & lastRow)
   Set SourceRange4 = wsDest.Range("J1:J" & lastRow)
   SourceRange.Copy
   
   'wsDest.Range("A1:D" & lastRow).Copy
   'wsDest.Columns(9).Delete
   Set y = Workbooks.Open("C:\SRQ VBA Test\Cable Collection Advices - 11.xls")
   y.Sheets(destsheetName).Range("C8").PasteSpecial xlPasteValues
   SourceRange2.Copy
   y.Sheets(destsheetName).Range("G8").PasteSpecial xlPasteValues
   SourceRange3.Copy
   y.Sheets(destsheetName).Range("I8").PasteSpecial xlPasteValues
   SourceRange4.Copy
   y.Sheets(destsheetName).Range("J8").PasteSpecial xlPasteValues
   lastRow2 = wsDest.Range("C" & Rows.Count).End(xlUp).Row
   y.Sheets(destsheetName).Range("A8:A" & lastRow2 + 7).Value = Format(Now(), "dd.mm.yyyy")
   y.Sheets(destsheetName).Range("B5").Value = Format(Now(), "dd.mm.yyyy")
   Application.DisplayAlerts = False
   Do While Len(FolDir) > 0
   If FolDir Like "Cable Collection Advices - " & "*" & ".xlsx" Then
   StrNum = Right(Left(FolDir, 32), 5)
   'MsgBox "StrNum" & StrNum
    NumStr = CInt(StrNum)
    If NumStr > MaxNum Then
    MaxNum = NumStr
    End If
    End If
    FolDir = Dir
    'Next FileNm
    Loop
    MaxStr = CStr(Format(MaxNum + 1))
    NewName = FolderStr & "Cable Collection Advices - " & MaxStr & ".xlsx"
    'MsgBox NewName
    y.SaveAs Filename:=NewName, FileFormat:=51, CreateBackup:=False
   y.Close SaveChanges:=False
   ActiveWorkbook.Worksheets("Filtered Data").Delete
   wsw.Activate
   MM1
   'Application.DisplayAlerts = True
Else
  MsgBox ("296699 No data")
  Application.DisplayAlerts = False
  ActiveWorkbook.Worksheets("Filtered Data").Delete
   Application.DisplayAlerts = True
   wsw.Activate
   MM1
End If


End Sub

Sub MM1() 'close all the worksheet autofilter
Dim ws As Worksheet
For Each ws In Worksheets
 'ws.AutoFilterMode = ShowAllData
    With ws
        If .AutoFilterMode Then
            If .FilterMode Then
            .ShowAllData
            End If
        End If
    End With
Next ws
End Sub
 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
Have you tried adding the line below after each paste command?
VBA Code:
application.cutcopymode = false

It will empty the clipboard after each paste - i would say your clipboard is overflowing.
 
Upvote 0
Next i would look to reduce the size of the copy range as the below will copy every cell on the sheet that is not hidden, this will include the blank area at the bottom of your data.
VBA Code:
wsw.Cells.SpecialCells(xlCellTypeVisible).Copy

Perhaps you could reduce the copy range using something like the below:
VBA Code:
wsw.UsedRange.SpecialCells(xlCellTypeVisible).Copy
 
Upvote 1
Solution
Next i would look to reduce the size of the copy range as the below will copy every cell on the sheet that is not hidden, this will include the blank area at the bottom of your data.
VBA Code:
wsw.Cells.SpecialCells(xlCellTypeVisible).Copy

Perhaps you could reduce the copy range using something like the below:
VBA Code:
wsw.UsedRange.SpecialCells(xlCellTypeVisible).Copy
It works! Thank you very much for your help.
 
Upvote 0

Forum statistics

Threads
1,223,227
Messages
6,170,853
Members
452,361
Latest member
d3ad3y3

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top