[Last Call] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 329
  • Last Modified:

Help With Out of Memory error message when looping through workbooks

Hello,

I've developed the following code that is executed from a master workbook that loops through  workbooks in a folder, opens the correct ones and then replaces three sheets in the destination workbook with three worksheets from the master workbook.  I keep getting an "Out of Memory Error"  I would like to get some advice on how to get rid of this error. Thanks.


Public Sub UpdateAllWorkbooks()
    ' Comments:
    ' Params  :
    ' Returns : Boolean
    ' Created : 08/13/12 14:45 JV
    ' Modified:
    
   
    On Error GoTo PROC_ERR
    
   
    Dim strPathOfSelectedFolder As String
    Dim strFilter As String
    Dim strCriteria As String
    Dim strSilo As String
    
    strPathOfSelectedFolder = Mid(ThisWorkbook.FullName, 1, InStrRev(ThisWorkbook.FullName, "\"))
    
    Set wbSource = ThisWorkbook
    
    'Replace ProjectID worksheet in each silo workbook with updated projectid worksheet
    
    strFilter = Dir(strPathOfSelectedFolder) 'change or add formats
    Do While strFilter <> "" 'will start LOOP until all files in folder sPath have been looped through
        strSilo = Left(strFilter, 6)
        Select Case strSilo
            Case "MFS_EA", "WOS_EA", "AFS_EA", "SGP_EA", "TRS_EA", "RES_EA"
                strCriteria = strPathOfSelectedFolder & strFilter
                Call OpenUserWorkbook(strCriteria, False)
            Case Else
                'Do Nothing
        End Select
        strFilter = Dir
    Loop ' End of LOOP

PROC_EXIT:
    Exit Sub

PROC_ERR:
    MsgBox Err.Description, vbCritical, "Admin.fnUpdateAllWorkbooks"
    Resume PROC_EXIT
  

End Sub

Public Sub OpenUserWorkbook(strFileName As String, fReadOnly As Boolean, Optional strPassword As String)
  ' Comments: Opens the named file and associates it with the class
  ' Params  : strFileName     Full path and name of the file to open
  '           fReadOnly       True to open readonly
  '           strPassword     Optional: specify the password if the workbook file is password protected.
    
  On Error GoTo PROC_ERR
  
  If Not IsMissing(strPassword) And strPassword <> "" Then
    Set wbDestination = Workbooks.Open(strFileName, fReadOnly, strPassword)
    For Each wsDestination In wbDestination.Worksheets
        If wsDestination.Name = "ProjectId" Then
            Set wsSource = wbDestination.Worksheets("ProjectId")
            Application.DisplayAlerts = False
            wsDestination.Delete
            wsSource.Copy before:=wbDestination.Worksheets(2)
            Application.DisplayAlerts = True
            Exit For
        End If
    Next wsDestination
    For Each wsDestination In wbDestination.Worksheets
        If wsDestination.Name = "Upload" Then
            Set wsSource = wbSource.Worksheets("Upload")
            Application.DisplayAlerts = False
            wsDestination.Delete
            wsSource.Copy before:=wbDestination.Worksheets(1)
            Application.DisplayAlerts = True
            Exit For
        End If
    Next wsDestination
    For Each wsDestination In wbDestination.Worksheets
        If wsDestination.Name = "Log" Then
            Set wsSource = wbSource.Worksheets("Log")
            Application.DisplayAlerts = False
            wsDestination.Delete
            wsSource.Copy after:=wbDestination.Worksheets(2)
            Application.DisplayAlerts = True
            Exit For
        End If
    Next wsDestination
    wbDestination.Close SaveChanges:=True
  Else
    Set wbDestination = Workbooks.Open(strFileName, fReadOnly)
    For Each wsDestination In wbDestination.Worksheets
        If wsDestination.Name = "ProjectId" Then
            Set wsSource = wbSource.Worksheets("ProjectId")
            Application.DisplayAlerts = False
            wsDestination.Delete
            wsSource.Copy before:=wbDestination.Worksheets(2)
            Application.DisplayAlerts = True
            Exit For
        End If
    Next wsDestination
    For Each wsDestination In wbDestination.Worksheets
        If wsDestination.Name = "Upload" Then
            Set wsSource = wbSource.Worksheets("Upload")
            Application.DisplayAlerts = False
            wsDestination.Delete
            wsSource.Copy before:=wbDestination.Worksheets(1)
            Application.DisplayAlerts = True
            Exit For
        End If
    Next wsDestination
    For Each wsDestination In wbDestination.Worksheets
        If wsDestination.Name = "Log" Then
            Set wsSource = wbSource.Worksheets("Log")
            Application.DisplayAlerts = False
            wsDestination.Delete
            wsSource.Copy after:=wbDestination.Worksheets(2)
            Application.DisplayAlerts = True
            Exit For
        End If
    Next wsDestination
    Application.DisplayAlerts = False
    wbDestination.Close SaveChanges:=True
    Application.DisplayAlerts = True
  End If
  
PROC_EXIT:
  Exit Sub

PROC_ERR:
  MsgBox "Error: " & Err.Number & ". " & Err.Description, , "CExcel.OpenWorkbook"
  Resume PROC_EXIT
End Sub

Open in new window

0
chtullu135
Asked:
chtullu135
  • 2
1 Solution
 
Arno KosterCommented:
in general for each object that is 'set' you should also 'release' the memory by setting the object to nothing. Next, if you open workbooks you could also close them again.
the wb.close false statement closes the workbook without saving it or asking if it is to be saved in case of any changes in the workbook

eg.
Set wbDestination = Workbooks.Open(strFileName, fReadOnly, strPassword)
[...]
wbDestination.Close False
set wbDestination = nothing

Open in new window

0
 
user_nCommented:
This type of error appears when there is a memory allocation in the code and this memory is not released before program finishing
0
 
chtullu135Author Commented:
Thanks akoster.
I tried setting wbDestination and that appeared to do the trick.  I'll test it a few more times to verify that the problem is fixed.  In addition, I reworked the code to eliminated some of the for loops.

Public Sub OpenUserWorkbook(strFileName As String, fReadOnly As Boolean, Optional strPassword As String)
  ' Comments: Opens the named file and associates it with the class
  ' Params  : strFileName     Full path and name of the file to open
  '           fReadOnly       True to open readonly
  '           strPassword     Optional: specify the password if the workbook file is password protected.
    
  On Error GoTo PROC_ERR
  
  Dim strWorksheetName As String
  
  If Not IsMissing(strPassword) And strPassword <> "" Then
    Set wbDestination = Workbooks.Open(strFileName, fReadOnly, strPassword)
      For Each wsDestination In wbDestination.Worksheets
        strWorksheetName = wsDestination.Name
        If strWorksheetName = "ProjectId" Or strWorksheetName = "Upload" Or strWorksheetName = "Log" Then
            Set wsSource = wbSource.Worksheets(strWorksheetName)
            Application.DisplayAlerts = False
            If strWorksheetName = "ProjectId" Then
                wsDestination.Delete
                wsSource.Copy before:=wbDestination.Worksheets(2)
            ElseIf strWorksheetName = "Upload" Then
                wsSource.Copy before:=wbDestination.Worksheets(1)
            ElseIf strWorksheetName = "Log" Then
                wsSource.Copy after:=wbDestination.Worksheets(2)
            End If
            Application.DisplayAlerts = True
        End If
    Next wsDestination
    wbDestination.Close SaveChanges:=True
    Set wbDestination = Nothing
  Else
    Set wbDestination = Workbooks.Open(strFileName, fReadOnly)
    For Each wsDestination In wbDestination.Worksheets
        strWorksheetName = wsDestination.Name
        If strWorksheetName = "ProjectId" Or strWorksheetName = "Upload" Or strWorksheetName = "Log" Then
            Set wsSource = wbSource.Worksheets(strWorksheetName)
            Application.DisplayAlerts = False
            If strWorksheetName = "ProjectId" Then
                wsDestination.Delete
                wsSource.Copy before:=wbDestination.Worksheets(2)
            ElseIf strWorksheetName = "Upload" Then
                wsSource.Copy before:=wbDestination.Worksheets(1)
            ElseIf strWorksheetName = "Log" Then
                wsSource.Copy after:=wbDestination.Worksheets(2)
            End If
            Application.DisplayAlerts = True
        End If
    Next wsDestination
    wbDestination.Close SaveChanges:=True
    Set wbDestination = Nothing
End If
  
PROC_EXIT:
  Exit Sub

PROC_ERR:
  MsgBox "Error: " & Err.Number & ". " & Err.Description, , "CExcel.OpenWorkbook"
  Resume PROC_EXIT
End Sub

Open in new window

0
 
chtullu135Author Commented:
Thanks for the help
0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now