0
\$\begingroup\$

I have built some code that should parse the data according to a unique value and then create a new Worksheet for each unique value. My initial table has 10 Columns and around 25K rows. The code works well for up to ca. 8500 rows. Above, I get the error message

not enough memory, etc...

Excel 64bits can not be installed on our work machines... Any ideas for a workaround? I just need this code to run in less than 3 hours and it will be a big win! Thanks!

Sub Split_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim OutPut As Integer



 'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
 'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.

Application.ScreenUpdating = False
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="10", Type:=1)
Set ws = Worksheets("Import") 'change worhseet name when necessary
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:J14"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 3 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
        ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
Next
Application.ScreenUpdating = False
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear

For i = 3 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
        Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
    Sheets(myarr(i) & "").Columns.AutoFit

Next

ws.AutoFilterMode = False
ws.Activate
Sheets("Instructions").Select

OutPut = MsgBox("Data successfully parsed", vbInformation, "Confirmation")
End Sub
\$\endgroup\$
5

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.