Solved

excel vba out of memory

Posted on 2015-01-16
3
239 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
Comment Utility
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
Comment Utility
Thank you so much
0
 
LVL 45

Expert Comment

by:aikimark
Comment Utility
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

What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

Join & Write a Comment

A2 = A1 That kind of cell reference is relative.  If you copy it from A2 to B2, then B2 will get this: B2 = B1 That's all fine and good, but if you then insert a new row above row 2, you'll find: A3 = A1 B3 = B1 This is intentional. …
Dealing with unintended Excel Active-X resizing quirks (VBA code simulates "self correction") David Miller (dlmille) Intro Not everyone is a fan of Active-X controls in spreadsheets (as opposed to the UserForm approach, the older Form controls …
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

772 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

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now