• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Run-time error '7' Out of Memory

begtc

New Member
Hello,

I am looking for assistance with the following VBA code. I am getting a Run-time error '7' Out of Memory which I do not know how to correct due to my limited VBA skills. I would greatly appreciate if someone could assist.
Code:
Sub ReadyForUpload()
    Application.ScreenUpdating = False

    Dim cell As Range
    For Each cell In Range("A:B, E:E")
        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
----------------------------------------------------------------------------
Mod edit: Code Tags added
 
Last edited by a moderator:
Hi ,

When you post a question on VBA execution errors , in addition to mentioning the type of error , please post the line of code which has generated the error ; this makes it easier to find the root cause of the problem.

Narayan
 
It appears that the code is failing at:

Code:
With ActiveSheet
.Columns.Hidden = False
.Rows.Hidden = False
.UsedRange.Value = .UsedRange.Value
End With
 
Hi ,

Never use the following statement :

Activesheet.UsedRange.Value = Activesheet.UsedRange.Value

Depending on how big Excel detects the UsedRange as , this can create Out of Memory errors.

If you know what your range of data is , use a static range reference , such as :

Activesheet.Range("A1:AK2000").Value = Activesheet.Range("A1:AK2000").Value

Narayan
 
I've updated the section of code which now looks like this:

Code:
  Dim cell As Range
    ActiveSheet.Range("A1:BD998").Value = ActiveSheet.Range("A1:BD998").Value
        If Len(cell) > 0 Then cell = UCase(cell)
    Next cell

I am getting an error now stating "Next without For"

Complete Code:
Code:
Sub ReadyForUpload()
    Application.ScreenUpdating = False

    Dim cell As Range
    ActiveSheet.Range("A1:BD998").Value = ActiveSheet.Range("A1:BD998").Value
        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
 
Hi ,

It helps to understand the code if it is properly indented.
Code:
Sub ReadyForUpload()
    Const Ffold As String = "\\WS0113\WLDepts$\Administration\Trade Compliance\IT\Integration Point\Daily - Product Classification Upload\"  'change as required
    Const MyTarget = "#N/A" ' <-- change to suit

    Dim Rng As Range, cell As Range
    Dim DelCol As New Collection
    Dim x
    Dim i As Long, j As Long, k As Long
    Dim Fname As String
   
    With ActiveSheet.Range("A1:BD998")
        .Value = .Value
    End With
       
    '    If Len(cell) > 0 Then cell = UCase(cell)
    'Next cell
 
  ' 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.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 Worksheet.Delete
    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

    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
I have commented out the following two lines of code :

If Len(cell) > 0 Then cell = UCase(cell)
Next cell

Since these statements are right at the top , you can clearly see two problems :

1. The variable cell has not been assigned any range reference

2. The Next keyword is supposed to be ending keyword for a For ... Next loop , but the For keyword is nowhere to be seen.

Can you correct these two omissions ?

Narayan
 
Back
Top