Excel 宏对 1000 多个数据运行异常

Question

我有一个 Excel 宏代码，用于从涉及以下内容的 GISAID 元数据中提取独特的突变:

1. 修剪每个值开头的“(”和结尾的“)”并自动填充修剪公式直到最后一行.
2. 粘贴(仅将修剪后的数据赋值到新工作表中)并拆分以逗号分隔的值。
3. 将所有多列行堆叠到一列中。
4. 删除所有空白单元格并将后续单元格向上移动(如果存在任何空白单元格)。
5. 删除重复项。

这是我设法构建的代码(我真的是 VBA 新手，我才开始自动化 Excel 流程，因为我几乎每天都在处理 GISAID 数据。)用户可以粘贴数据从 GISAID 的 .tsv 元数据到 A1 并运行宏。

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

这对于最多 1000 行数据非常有效，但如果我开始将超过 1100 行的数据粘贴到 A 列，它就会开始运行怪异，并给我提供不在单个列中的结果。如果进程完全相同，我不确定为什么它的运行方式不同。谁能帮忙？非常感谢!

WEIRD RESULT

EXPECTED RESULT

Answer 1

@VBasic2008 打败了我，但还是发布了这个:

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