Run - Time Error 7 Out of Memory Error Message

[bepedicino]

I am getting a Run - Time Error 7 Out of Memory error message on the following code. Can anyone assist with the error?

With ActiveSheet
.Columns.Hidden = False
.Rows.Hidden = False
.UsedRange.Value = .UsedRange.Value
End With

Here is the complete code.

Sub ReadyForUpload()
 
    Application.ScreenUpdating = False


    Dim cell As Range
    For Each cell In Range("A1:B1001, E1:E1001")
        If Len(cell) > 0 Then cell = UCase(cell)
    Next cell
    
    Application.ScreenUpdating = True
    
  Const MyTarget = "#N/A" ' <-- change to suit
  
  Dim Rng As Range, DelCol As New Collection, x
  Dim i As Long, j As Long, k As Long
  
  ' Calc last row number
  j = Cells.SpecialCells(xlCellTypeLastCell).Row  'can be: j = Range("C" & Rows.Count).End(xlUp).Row
  
  ' Collect rows range with MyTarget
  For i = 1 To j
    If WorksheetFunction.CountIf(Rows(i), MyTarget) > 0 Then
      k = k + 1
      If k = 1 Then
        Set Rng = Rows(i)
      Else
        Set Rng = Union(Rng, Rows(i))
        If k >= 100 Then
          DelCol.Add Rng
          k = 0
        End If
      End If
    End If
  Next
  If k > 0 Then DelCol.Add Rng
  
  ' Turn off screen updating and events
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  
  ' Delete rows with MyTarget
  For Each x In DelCol
    x.Delete
  Next
  
  ' Update UsedRange
  With ActiveSheet.UsedRange: End With
  
  ' Restore screen updating and events
  Application.ScreenUpdating = True
  Application.EnableEvents = True




With Application
.Calculate
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With


With ActiveSheet
.Columns.Hidden = False
.Rows.Hidden = False
.UsedRange.Value = .UsedRange.Value
End With


For Each Worksheet In ThisWorkbook.Worksheets
If Worksheet.Name = ActiveSheet.Name Then
Else
Worksheet.Delete
End If
Next Worksheet


With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With


Columns("U").NumberFormat = "@"


Range("A:E").Replace Chr(10), ""


Range("A:E").Replace Chr(13), ""


Columns("F").Delete


Columns("I").Delete


    Const Ffold As String = "\\WS0113\WLDepts$\Administration\Trade Compliance\IT\Integration Point\Daily - Product Classification Upload\"   'change as required
    Dim Fname As String
    
    Fname = "Product Classification Upload"
    Fname = Fname & " - " & Format(Date, "yyyymmdd") & ".xlsx"
    
    Application.DisplayAlerts = False
    
  ActiveWorkbook.SaveAs _
        Filename:=Ffold & Application.PathSeparator & Fname, _
        FileFormat:=xlOpenXMLWorkbook
    
    Application.DisplayAlerts = True


End Sub

 

[igold]

Cross posted at: Run-time error '7' Out of Memory | Chandoo.org Excel Forums - Become Awesome in Excel

If you cross post (posting the same question in more than one forum), please provide a link to your post. Please see Rule #13.