Excel 宏在 1000 多个数据下运行异常

Question

我有一个 Excel 宏代码来从 GISAID 元数据中提取独特的突变，涉及：

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

这是我设法构建的代码（我在 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

拆分 Comma-Delimited 数据到列

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 打败了我，但还是发布了这个：

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

Excel 宏在 1000 多个数据下运行异常

Excel macro runs weird with 1000+ data

excel

vba

duplicates

拆分 Comma-Delimited 数据到列