Solved

excel vba out of memory

Posted on 2015-01-16
3
264 Views
Last Modified: 2015-01-16
I am running some vba that connects to sql server and pulls back records and then inserts it into multiple tabs.   The code parses out different queries based on where it finds a ";" in the text file.   The issue I am having is that on ones that it pulls back large amounts of data, I get an out of memory error.  The data still returns, so it is just a message.  


Sub ExecuteSqlScript(FilePath As String)

    Dim Script As String
    Dim FileNumber As Integer
    Dim Delimiter As String
    Dim aSubscript() As String
    Dim Subscript As String
    Dim i As Long
    Dim comm As New ADODB.Command
    Dim rs As New ADODB.Recordset
    Dim dbConnectStr As String
    Dim StrSheet0 As String
    Dim strRange0 As String
    Dim StrSheet1 As String
    Dim strRange1 As String
    Dim StrSheet2 As String
    Dim strRange2 As String
    Dim StrSheet3 As String
    Dim strRange3 As String
    Dim StrSheet4 As String
    Dim strRange4 As String
    Dim StrSheet5 As String
    Dim strRange5 As String
    Dim StrSheet6 As String
    Dim strRange6 As String


    StrSheet0 = ThisWorkbook.Worksheets("Control").Range("C21").Value
    strRange0 = ThisWorkbook.Worksheets("Control").Range("D21").Value
    StrSheet1 = ThisWorkbook.Worksheets("Control").Range("C22").Value
    strRange1 = ThisWorkbook.Worksheets("Control").Range("D22").Value
    StrSheet2 = ThisWorkbook.Worksheets("Control").Range("C23").Value
    strRange2 = ThisWorkbook.Worksheets("Control").Range("D23").Value
    StrSheet3 = ThisWorkbook.Worksheets("Control").Range("C24").Value
    strRange3 = ThisWorkbook.Worksheets("Control").Range("D24").Value
    StrSheet4 = ThisWorkbook.Worksheets("Control").Range("C25").Value
    strRange4 = ThisWorkbook.Worksheets("Control").Range("D25").Value
    StrSheet5 = ThisWorkbook.Worksheets("Control").Range("C26").Value
    strRange5 = ThisWorkbook.Worksheets("Control").Range("D26").Value
    StrSheet6 = ThisWorkbook.Worksheets("Control").Range("C27").Value
    strRange6 = ThisWorkbook.Worksheets("Control").Range("D27").Value


    Application.CutCopyMode = False

    Set comm.ActiveConnection = cn
    rs.ActiveConnection = cn

    Delimiter = ";"
    FileNumber = FreeFile
    Script = String(FileLen(FilePath), vbNullChar)

    ' Grab the scripts inside the file
    Open FilePath For Binary As #FileNumber
    Get #FileNumber, , Script
    Close #FileNumber


    ' Put the scripts into an array
    aSubscript = Split(Script, Delimiter)

    ' Run each script in the array
    For i = 0 To UBound(aSubscript) - 1
        aSubscript(i) = Trim(aSubscript(i))
        Subscript = aSubscript(i)
        ' Debug.Print Subscript
        comm.CommandText = Subscript
        comm.CommandTimeout = 0
        rs.Open comm

        If i = 0 Then
            Sheets(StrSheet0).Select
            Range("A2:R1048575").Select
            Selection.ClearContents

            Sheets(StrSheet0).Range(strRange0).CopyFromRecordset rs
            FormulaFill
        Else    'Nothing
        End If
       
        If i = 1 Then
            Sheets(StrSheet1).Select
            Range("A6:B1000000").Select
            Selection.ClearContents

            Sheets(StrSheet1).Range(strRange1).CopyFromRecordset rs
            FormulaFill
        Else    'Nothing
        End If
        
        If i = 2 Then
            Sheets(StrSheet2).Select
            Range("A2:L1048575").Select
            Selection.ClearContents

            Sheets(StrSheet2).Range(strRange2).CopyFromRecordset rs
        Else    'Nothing
        End If
        Application.CutCopyMode = False
        If i = 3 Then
            Sheets(StrSheet3).Select
            Range("C28:F32").Select
            Selection.ClearContents

            Sheets(StrSheet3).Range(strRange3).CopyFromRecordset rs
        Else    'Nothing
        End If
       
        If i = 4 Then
            Sheets(StrSheet4).Select
            Range("A2:D1048575").Select
            Selection.ClearContents

            Sheets(StrSheet4).Range(strRange4).CopyFromRecordset rs
        Else    'Nothing
        End If
        
        If i = 5 Then
            Sheets(StrSheet5).Select
            Range("A2:E1048575").Select
            Selection.ClearContents

            Sheets(StrSheet5).Range(strRange5).CopyFromRecordset rs
        Else    'Nothing
        End If
        
        If i = 6 Then
            Sheets(StrSheet6).Select
            Range("A2:D1048575").Select
            Selection.ClearContents

            Sheets(StrSheet6).Range(strRange6).CopyFromRecordset rs
        Else    'Nothing
        End If
        
        rs.Close
        Set rs = Nothing
   

    Next i

    Application.CutCopyMode = False

   

    

End Sub

Open in new window

0
Comment
Question by:montrof
  • 2
3 Comments
 
LVL 45

Accepted Solution

by:
aikimark earned 500 total points
ID: 40554256
This will give you some memory relief
    ' Put the scripts into an array
    aSubscript = Split(Script, Delimiter)
    Script = vbNullString

Open in new window

0
 
LVL 1

Author Closing Comment

by:montrof
ID: 40554259
Thank you so much
0
 
LVL 45

Expert Comment

by:aikimark
ID: 40554286
While I was looking at the code, I simplified it.
Sub ExecuteSqlScript(FilePath As String)

    Dim Script As String
    Dim FileNumber As Integer
    Dim Delimiter As String
    Dim aSubscript() As String
    Dim Subscript As String
    Dim i As Long
    Dim comm As New ADODB.Command
    Dim rs As New ADODB.Recordset
    Dim dbConnectStr As String
    Dim StrSheet0 As String
    Dim strRange0 As String
    Dim StrSheet1 As String
    Dim strRange1 As String
    Dim StrSheet2 As String
    Dim strRange2 As String
    Dim StrSheet3 As String
    Dim strRange3 As String
    Dim StrSheet4 As String
    Dim strRange4 As String
    Dim StrSheet5 As String
    Dim strRange5 As String
    Dim StrSheet6 As String
    Dim strRange6 As String
    Dim wks As Worksheet

    StrSheet0 = ThisWorkbook.Worksheets("Control").Range("C21").Value
    strRange0 = ThisWorkbook.Worksheets("Control").Range("D21").Value
    StrSheet1 = ThisWorkbook.Worksheets("Control").Range("C22").Value
    strRange1 = ThisWorkbook.Worksheets("Control").Range("D22").Value
    StrSheet2 = ThisWorkbook.Worksheets("Control").Range("C23").Value
    strRange2 = ThisWorkbook.Worksheets("Control").Range("D23").Value
    StrSheet3 = ThisWorkbook.Worksheets("Control").Range("C24").Value
    strRange3 = ThisWorkbook.Worksheets("Control").Range("D24").Value
    StrSheet4 = ThisWorkbook.Worksheets("Control").Range("C25").Value
    strRange4 = ThisWorkbook.Worksheets("Control").Range("D25").Value
    StrSheet5 = ThisWorkbook.Worksheets("Control").Range("C26").Value
    strRange5 = ThisWorkbook.Worksheets("Control").Range("D26").Value
    StrSheet6 = ThisWorkbook.Worksheets("Control").Range("C27").Value
    strRange6 = ThisWorkbook.Worksheets("Control").Range("D27").Value

    Application.ScreenUpdating = False
    Application.CutCopyMode = False

    Set comm.ActiveConnection = cn
    rs.ActiveConnection = cn

    Delimiter = ";"
    FileNumber = FreeFile
    Script = String(FileLen(FilePath), vbNullChar)

    ' Grab the scripts inside the file
    Open FilePath For Binary As #FileNumber
    Get #FileNumber, , Script
    Close #FileNumber


    ' Put the scripts into an array
    aSubscript = Split(Script, Delimiter)
    Script = vbNullString
    
    ' Run each script in the array
    For i = 0 To UBound(aSubscript) - 1
        aSubscript(i) = Trim(aSubscript(i))
        Subscript = aSubscript(i)
        ' Debug.Print Subscript
        comm.CommandText = Subscript
        comm.CommandTimeout = 0
        rs.Open comm

        If i = 0 Then
            Set wks = Sheets(StrSheet0)
            wks.Range("A2:R1048575").ClearContents

            wks.Range(strRange0).CopyFromRecordset rs
            FormulaFill
        End If
       
        If i = 1 Then
            Set wks = Sheets(StrSheet1)
            wks.Range("A6:B1000000").ClearContents

            wks.Range(strRange1).CopyFromRecordset rs
            FormulaFill
        End If
        
        If i = 2 Then
            Set wks = Sheets(StrSheet2)
            wks.Range("A2:L1048575").ClearContents

            wks.Range(strRange2).CopyFromRecordset rs
        End If
        Application.CutCopyMode = False
        If i = 3 Then
            Set wks = Sheets(StrSheet3)
            wks.Range("C28:F32").ClearContents

            wks.Range(strRange3).CopyFromRecordset rs
        End If
       
        If i = 4 Then
            Set wks = Sheets(StrSheet4)
            wks.Range("A2:D1048575").ClearContents

            wks.Range(strRange4).CopyFromRecordset rs
        End If
        
        If i = 5 Then
            Set wks = Sheets(StrSheet5)
            wks.Range("A2:E1048575").ClearContents

            wks.Range(strRange5).CopyFromRecordset rs
        End If
        
        If i = 6 Then
            Set wks = Sheets(StrSheet6)
            wks.Range("A2:D1048575").ClearContents

            wks.Range(strRange6).CopyFromRecordset rs
        End If
        
        rs.Close
        Set rs = Nothing

    Next i

    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

Open in new window


If you posted the workbook, I might be able to simplify it further.  I suspect the ranges you are clearing are the same ranges you are populating.
0

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.

840 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question