我有一個 Excel 宏代碼來從 GISAID 元資料中提取獨特的突變，其中包括：
- 修剪開頭的“ （ ”和每個值末尾的“ ） ”，并自動填充修剪公式直到最后一行。
- 粘貼（僅將修剪后的資料賦值到新作業表中）并拆分逗號分隔的值。
- 將所有多列行堆疊成一列。
- 洗掉所有空白單元格并將后續單元格向上移動（如果存在任何空白單元格）。
- 洗掉重復項。
這是我設法構建的代碼（我在 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
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
uj5u.com熱心網友回復：
@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
uj5u.com熱心網友回復：
將逗號分隔的資料拆分為列
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
轉載請註明出處，本文鏈接：https://www.uj5u.com/qukuanlian/449922.html
標籤：excel vba duplicates