VBA for Excel is running out of resources

Question

I have an excel worksheet that I need to divide up into several smaller worksheets based upon the value of one column. The code works great, but runs out of resources when it gets past row 10k.

I think that the problem is when I'm trying to find the last row, so I was wondering if there was a more efficient workaround to avoid the memory problem. Or perhaps this isn't the problem anyway?

The code follows.

Sub Fill_Cells()

Dim masterSheet As Worksheet
Dim masterSheetName As String
Dim TRRoom As String, tabName As String

Dim lastRowNumber As Long
Dim j As Long

Application.ScreenUpdating = False

masterSheetName = "Master"

Set masterSheet = Worksheets(masterSheetName)

lastRowNumber = masterSheet.Cells.Find("*", SearchOrder:=xlByRows,      SearchDirection:=xlPrevious).Row

j = 4

For Each c In masterSheet.Range("AB4:AB" & lastRowNumber).Cells

  TRRoom = c.Value
  tabName = "TR-" & TRRoom
  localLastRowNumber = Worksheets(tabName).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  insertRow = localLastRowNumber + 1

Worksheets(tabName).Rows(insertRow).Value = masterSheet.Rows(j).Value

j = j + 1

Next

End Sub

If anyone could help me with this, I would appreciate it.

Zev Spitz · Answer 1 · 2018-05-03T05:27:57.767

I would suggest using an ADODB Connection, and SQL statements to read from and write to the worksheets. Treating the Excel file as a database is generally much faster than working through the Excel Automation API.

Via Tools -> References..., add a reference to Microsoft ActiveX Data Objects 2.8 Library (or the latest version installed on your machine). Then the following code will give you a connection to the current workbook:

Dim conn As New Connection
With conn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .ConnectionString = "Data Source=""" & ActiveWorkbook.FullName & """;" & _
        "Extended Properties=""Excel 12.0;HDR=No;"""
    'If you're running a version of Excel earlier than 2007, the connection string should look like this:
    '.ConnectionString = "Data Source=""" & ActiveWorkbook.FullName & """;" & _
    '    "Extended Properties=""Excel 8.0;HDR=No;"""
    .Open
End With

Then, you can get a list of unique TRRooms:

Dim rs As Recordset
Set rs = conn.Execute("SELECT DISTINCT F28 FROM [Master$]")
'Field F28, because if you specify that your range does not have header rows (HDR=No 
'in the connection string) ADODB will automatically assign field names for each field
'Column AB is the 28th column in the worksheet

and insert the relevant rows into the appropriate worksheet:

Do Until rs.EOF
    Dim trroom As String
    trroom = rs!F28
    conn.Execute _
        "INSERT INTO [TR-" & trroom & "$] " & _
        "SELECT * " & _
        "FROM [Master$] " & _
        "WHERE F28 = """ & trroom & """"
    rs.MoveNext
Loop

See here for some references about ADODB.

Update

AFAIK, Excel 2013 and later prevent executing SQL statements that modify data (INSERT, UPDATE, DELETE) against Excel worksheets. But this can often be replaced with a call to the Range.CopyFromRecordet method:

Do Until rs.EOF
    Dim sql As String
    sql = _
        "SELECT * " & _
        "FROM [Master$] " & _
        "WHERE F28 = """ & rs!F28 & """"
    Worksheets(rs!F28).Range.CopyFromRecordset conn.Execute(sql)
    rs.MoveNext
Loop

This is also a new approach that I had never even considered. I'll have to play around with that. — hunterman9, Aug 27 '13 at 20:19
+1 really nice suggestion: I use similar code against sql-server but never fired it back against Excel (& have been writing `VBA` for over 10 yrs!) will have a play with this myself. — whytheq, Aug 27 '13 at 21:08
@hunterman9 Note that `INSERT INTO ...` inserts into existing worksheets. In order to create new worksheets, use `SELECT INTO ...`. See [here](http://office.microsoft.com/en-us/access-help/select-into-statement-HA001231498.aspx?CTT=1) for full syntax. — Zev Spitz, Aug 27 '13 at 22:33

score 1 · Answer 2 · answered Aug 27 '13 at 17:57

I tested this on a dataset of 20,000 rows with 26 different worksheets and it completed in about 20 seconds on my machine with no errors. Let me know if this works for you.

Sub Fill_Cells()

    Dim ws As Worksheet
    Dim wsMaster As Worksheet
    Dim rngFound As Range
    Dim rngCopy As Range
    Dim lCalc As XlCalculation
    Dim strFind As String
    Dim strFirst As String

    Set wsMaster = Sheets("Master")

    With Application
        lCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    On Error GoTo CleanExit

    For Each ws In Sheets
        If UCase(Left(ws.Name, 3)) = "TR-" Then
            strFind = Mid(ws.Name, 4)
            With wsMaster.Columns("AB")
                Set rngFound = .Find(strFind, , xlValues, xlWhole)
                If Not rngFound Is Nothing Then
                    strFirst = rngFound.Address
                    Set rngCopy = rngFound
                    Do
                        Set rngCopy = Union(rngCopy, rngFound)
                        Set rngFound = .Find(strFind, rngFound, xlValues, xlWhole)
                    Loop While rngFound.Address <> strFirst
                    rngCopy.EntireRow.Copy
                    ws.Cells(ws.Cells.Find("*", ws.Range("A1"), SearchDirection:=xlPrevious).Row + 1, "A").PasteSpecial xlPasteValues
                End If
            End With
        End If
    Next ws

CleanExit:
    With Application
        .CutCopyMode = False
        .Calculation = lCalc
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    If Err.Number <> 0 Then
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If

    Set ws = Nothing
    Set wsMaster = Nothing
    Set rngFound = Nothing
    Set rngCopy = Nothing

End Sub

Thanks for our help. Unfortunately, that isn't working right. I'm not an expert VB programmer, but it seems that your code is doing the opposite what what I need. I have one worksheet that has a master list of all the rooms in a building with each room's associated data. I need to divide the list up between zones in separate worksheets based upon a room code found in column AB. Your code seems to loop through all the sheets to find the data to copy. — hunterman9, Aug 27 '13 at 19:10
That is correct. Your code assumes that the sheets already exist, and it is much easier for Excel to find all rows containing a value rather than loop through each value in a column. This code finds all values in the Master worksheet and copies all relevant rows to the intended worksheet. It does perform exactly as your original code would, just more efficient and using a different approach — tigeravatar, Aug 27 '13 at 19:22
I like the approach, it just isn't working. I am in the debugging process of stepping though the loop with watches to see where the problem is. By the way, the reason that I assumed the sheets exist is because immediately prior to this code, the sheets are created and verified. So in this case, assuming that they exist is rather safe. I'll post another comment when I can figure out why it isn't working. — hunterman9, Aug 27 '13 at 20:17
I can't explain why it didn't work the first time I tried it. The If Not rngFound is Nothing statement seemed to not pick anything up. However, when I tried it the second time, everything worked fine. Maybe I screwed up copying it into the module window or something. In any case, it works perfectly, and as you said, much faster than before. Thanks again! — hunterman9, Aug 29 '13 at 12:23

score 1 · Answer 3 · answered Aug 28 '13 at 06:05

Sort the master sheet (or a copy of it) on the TRRoom column. All of the entries for the same TRRoom will be grouped together.

For each TRRoom you will only need to find the last row on the relevant tab on the first occurrence of this TRRoom. After that both the lastRowNumber and localLastRowNumber will increase in step with each other.

If there's some further ordering on the master sheet which you need to preserve then add a dummy column and autofill it with 1, 2, 3 etc. before sorting the TRRoom

score 0 · Answer 4 · answered Aug 27 '13 at 21:18

(not a solution)

If you run the following what do you see in the immediate window:

Sub Fill_Cells()

Dim masterSheetName As String
Dim masterSheet As Excel.Worksheet

Dim TRRoom As String
Dim tabName As String

Dim lastRowNumber As Long
Dim j As Long
j = 4

Excel.Application.ScreenUpdating = False

masterSheetName = "Master"
Set masterSheet = Excel.ThisWorkbook.Worksheets(masterSheetName)

lastRowNumber = masterSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For Each cell In masterSheet.Range("AB4:AB" & lastRowNumber).Cells

    TRRoom = c.Value
    tabName = "TR-" & TRRoom
    localLastRowNumber = Excel.ThisWorkbook.Worksheets(tabName).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Debug.Print localLastRowNumber '<<<<<interested to see what values are getting assigned here by printing the values to the immediate window.

    insertRow = localLastRowNumber + 1

    Excel.ThisWorkbook.Worksheets(tabName).Rows(insertRow).Value = masterSheet.Rows(j).Value

j = j + 1
Next cell

End Sub

VBA for Excel is running out of resources

4 Answers4

Linked