Split data based on a column causing column/memory issue

[Nieriel]

Hi All,
I am using the below macro to split out data based on column J however once it has split each sheet (there are 119 in total) is expanding to column XFD.
This is causing a memory issue when I try and run another macro to remove columns J and K once it has been split - is there something I can add to the below code that will stop it adding all these columns?
All my sheets will only go to column L if that helps?

This is the code I am using at the minute (also I am relatively new to VBA so sorry if there is an obvious answer)

Sub Macro2ExportSplit()
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
vcol = 10
Set ws = Sheets("Export")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:L1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 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
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 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
End Sub

 

[pbornemeier]

I made some guesses on what the portions of the code/layout you did not provide is doing. Please test this code on a copy of your data.

Sub CopyDataToDiffSheetsBasedOnColumnsData()
    'Create a worksheet for each value in the designated ID column and copy matching data to it
    
    Const lIDColumn As Long = 10 'Column that determines how data is split
    Dim aryUniques As Variant
    Dim lIndex As Long
    Dim lLastIDRow As Long
    Dim lLastIDCol As Long
    Dim sWorksheet As String
    
    With Worksheets("Export")
        .AutoFilterMode = False
        
        lLastIDRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lLastIDCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        'Extract ID Column Unique values (row 2 and below)
        aryUniques = ReturnUniqueValues(.Range(.Cells(2, lIDColumn), .Cells(lLastIDRow, lIDColumn)))
        aryUniques = BubbleSortArray(aryUniques)
        For lIndex = LBound(aryUniques) To UBound(aryUniques)
            sWorksheet = aryUniques(lIndex)
            .Range("A1").CurrentRegion.AutoFilter Field:=lIDColumn, Criteria1:=sWorksheet
            If Application.WorksheetFunction.Subtotal(3, Columns(lIDColumn)) > 1 Then
                'More than the header row is visible
                
                'Delete/ReCreate Target Worksheet
                On Error Resume Next
                Application.DisplayAlerts = False
                Worksheets(sWorksheet).Delete
                Application.DisplayAlerts = True
                On Error GoTo 0
                Worksheets.Add(After:=Sheets(Sheets.Count)).Name = sWorksheet 'After last
                
                'Copy filtered data to new worksheet
                .Range(.Cells(1, 1), .Cells(lLastIDRow, lLastIDCol)).SpecialCells(xlCellTypeVisible).Copy _
                    Destination:=Worksheets(sWorksheet).Range("A1")
            End If
    
        Next
        .AutoFilterMode = False
        
    End With

End Sub

Function ReturnUniqueValues(rngInput As Range) As Variant
    'Given an input range, return unique values from that range as an 0-based array
    
    Dim rngCell As Range
    Dim oDict As Object
    
    Set oDict = CreateObject("scripting.dictionary")
    For Each rngCell In rngInput
        If Not oDict.exists(rngCell.Value) Then
            oDict.Add rngCell.Value, 1 'Add & Include first row number
        End If
    Next rngCell
    ReturnUniqueValues = oDict.Keys
    Set oDict = Nothing
    
End Function

Function BubbleSortArray(ary As Variant)

    Dim lX As Long, lY As Long
    Dim varTemp As Variant
    
    For lX = LBound(ary) To UBound(ary) - 1
        For lY = lX + 1 To UBound(ary)
            If ary(lX) > ary(lY) Then
                varTemp = ary(lY)
                ary(lY) = ary(lX)
                ary(lX) = varTemp
            End If
        Next
    Next
    BubbleSortArray = ary
    
End Function