Solved

excel vba out of memory

Posted on 2015-01-16
3
256 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

Live: Real-Time Solutions, Start Here

Receive instant 1:1 support from technology experts, using our real-time conversation and whiteboard interface. Your first 5 minutes are always free.

Question has a verified solution.

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

Introduction While answering a recent question (http:/Q_27311462.html), I created an alternative function to the Excel Concatenate() function that you might find useful.  I tested several solutions and share the results in this article as well as t…
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.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.
Many functions in Excel can make decisions. The most simple of these is the IF function: it returns a value depending on whether a condition you describe is true or false. Once you get the hang of using the IF function, you will find it easier to us…

786 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