Excel macro runs weird with 1000+ data

Question

I have an Excel macro code to extract unique mutations from GISAID metadata that involves:

1. Trimming the "(" in the very beginning and the ")" in the very end of each value and auto-filling the trim formula down until the last row.
2. Pasting (values only the trimmed data into a new sheet) and splitting the comma-delimited values.
3. Stacking all the multi-columned rows into one column.
4. Deleting all blank cells and shifting the subsequent cells up (if any blank cells are present).
5. Removing duplicates.

This is the code that I've managed to build (I'm really really new in VBA, I've only started automating Excel processes because I'm working with GISAID data almost every day.) Users can paste the data from GISAID's .tsv metadata to A1 and just run the macro.

Sub MUTATIONS_MACRO()
'
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

' MUTATIONS_MACRO_EXCEL_1 Macro
'
'
    Range("B1").Select
    Dim Lr As Long
    Lr = Cells(Rows.Count, "A").End(xlUp).Row
    Range("B1:B" & Lr).Formula = "=RIGHT((LEFT(RC[-1], LEN(RC[-1])-1)), LEN(LEFT(RC[-1], LEN(RC[-1])-1))-1)"

    Range("B1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet

    Range("A1").PasteSpecial Paste:=xlPasteValues
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.TextToColumns _
    Destination:=Range("A1"), DataType:=xlDelimited, _
    ConsecutiveDelimiter:=False, Comma:=True

    ActiveCell.Rows("1:1").EntireRow.Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.Delete Shift:=xlUp

    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
        
    Dim vaCells As Variant
    Dim vOutput() As Variant
    Dim i As Long, j As Long
    Dim lRow As Long

    If TypeName(Selection) = "Range" Then
        If Selection.Count > 1 Then
            If Selection.Count <= Selection.Parent.Rows.Count Then
                vaCells = Selection.Value

                ReDim vOutput(1 To UBound(vaCells, 1) * UBound(vaCells, 2), 1 To 1)

                For j = LBound(vaCells, 2) To UBound(vaCells, 2)
                    For i = LBound(vaCells, 1) To UBound(vaCells, 1)
                        If Len(vaCells(i, j)) > 0 Then
                            lRow = lRow + 1
                            vOutput(lRow, 1) = vaCells(i, j)
                        End If
                    Next i
                Next j

                Selection.ClearContents
                Selection.Cells(1).Resize(lRow).Value = vOutput
            End If
        End If
    End If
    
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveSheet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

This works perfectly for up to 1000 rows of data but if I start pasting more than 1100-ish rows onto column A, it starts to run weird and gives me results that are not in a single column. I'm not sure why it's running differently if the processes are exactly the same. Can anyone help? Thank you so much!

WEIRD RESULT

EXPECTED RESULT

Answer 1

Split Comma-Delimited Data to Column

Option Explicit

Sub ExtractMutations()
    
    ' Source
    Const sName As String = "PASTE"
    Const sFirstCellAddress As String = "A1"
    Const sDelimiter As String = ","
    ' Destination
    Const dName As String = "Mutations"
    Const dFirstCellAddress As String = "A1"
    Const dNameIncrementDelimiter As String = ""
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Reference the source one-column range and write its values
    ' to a 2D one-based one-column array.
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range
    Dim rCount As Long
    With sws.Range(sFirstCellAddress)
        Dim slCell As Range: Set slCell = .Resize(sws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If slCell Is Nothing Then Exit Sub
        rCount = slCell.Row - .Row + 1
        Set srg = .Resize(rCount)
    End With
    Dim sAddress As String: sAddress = srg.Address
    Dim Data As Variant
    ' Get rid of the parentheses.
    Data = sws.Evaluate("MID(" & sAddress & ",2,LEN(" & sAddress & ")-2)")
    
    ' Split the array data into a dictionary removing duplicates.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim Key As Variant
    Dim r As Long
    
    For r = 1 To rCount
        For Each Key In Split(Data(r, 1), sDelimiter)
            If Not IsError(Key) Then
                If Len(Key) > 0 Then
                    dict(Key) = Empty
                End If
            End If
        Next Key
    Next r
    
    ' Write the values from the dictionary to a 2D one-based one-column array.
    
    rCount = dict.Count
    ReDim Data(1 To rCount, 1 To 1)
    r = 0
    
    For Each Key In dict.Keys
        r = r + 1
        Data(r, 1) = Key
    Next Key
        
    ' Write the values from the array to the destination range.
    
    Dim DN As String: DN = dName
    r = 0
    
    With wb.Worksheets.Add(After:=sws)
        ' If the destination worksheet name is taken, add an increment
        Dim ErrNum As Long
        Do
            On Error Resume Next
                .Name = DN
                r = r + 1: DN = dName & dNameIncrementDelimiter & r
                ErrNum = Err.Number
            On Error GoTo 0
        Loop Until ErrNum = 0
        ' Write result.
        With .Range(dFirstCellAddress)
            .Resize(rCount).Value = Data
            .EntireColumn.AutoFit
        End With
    End With
    ' Save the workbook.
    'wb.Save
    
    ' Inform.
    
    MsgBox "Mutations extracted.", vbInformation
        
End Sub

Answer 2

@VBasic2008 beat me to it, but posting this anyway:

Sub MUTATIONS_MACRO()
    
    Dim dict As Object, c As Range, arr, v, data, ws As Worksheet, r As Long, e
    Set dict = CreateObject("scripting.dictionary")
    
    Set ws = ActiveSheet
    'get all data as an array
    data = ActiveSheet.Range("A1:A" & ws.Cells(Rows.Count, 1).End(xlUp).Row).Value
    
    For r = 1 To UBound(data, 1)         'loop over the array and process each value
        v = Trim(data(r, 1))             'read the value
        If Len(v) > 2 Then               'not blank/too short?
            v = Mid(v, 2, Len(v) - 2)    'remove ()
            arr = Split(v, ",")          'split on comma
            For Each e In arr            'loop values
                dict(CStr(Trim(e))) = 1  'put in dictionary (unique only)
            Next e
        End If
    Next r
    
    DictKeysToSheet dict, ws.Parent.Worksheets.Add.Range("A1")
        
End Sub

'add a dictionary's keys to a sheet as a column starting at range `c`
Sub DictKeysToSheet(dict As Object, c As Range)
    Dim arr(), keys, i As Long, r As Long
    keys = dict.keys
    ReDim arr(1 To dict.Count, 1 To 1)
    r = 1
    For i = LBound(keys) To UBound(keys)
        arr(r, 1) = keys(i)
        r = r + 1
    Next i
    c.Resize(dict.Count).Value = arr
End Sub