excel - 拆分/复制/移动单元格内容到预先指定/对应的列

Question

我有以下情况。在 Excel 工作表中，我有一列包含由“|”分隔的值。例如

Option Column
Option 1 | Option 3
Option 4 | Option 7
Option 2 | Option 3 | Option 6

我想要

1. Insert 10 columns to the right, name them "Option 1", "Option 2", "Option 3" ..... "Option 10"
2. In each cell of the first column, if "Option x" exists, split/copy/move to the column named "Option x" (Where x can be 1, 2 .... 10)

这是我目前用来实现它的代码：

   Sub Insert_10_columns()
    Columns("B:K").Insert Shift:=xlToRight, _
      CopyOrigin:=xlFormatFromLeftOrAbove
    For i = 2 To 11
    ActiveSheet.Cells(1, i).Value = "Option " & i - 1
    Next i
End Sub

Sub Look_For_Text()
    Dim LastRow As Long
    LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To LastRow + 1
        For k = 1 To 10
            If InStr(1, (Cells(i, 1).Value), "Option " & k) > 0 Then
            ActiveSheet.Cells(i, k + 1).Value = "Option " & k
            End If
        Next k
    Next i
End Sub

我只是想知道循环是否是最好的方法，特别是因为当我开始使用它时，我将在 20,000 多行和 15 多列上进行操作。

标签： excelvba

Answer 1

变体使用System.Collections.ArrayListand Scripting.Dictionary，我想这应该比您的解决方案更快）

Sub test()
    Dim data As Range, cl As Range, i&, x As Variant
    Dim arrList As Object, Dic As Object
    Set arrList = CreateObject("System.Collections.ArrayList")
    Set Dic = CreateObject("Scripting.Dictionary")
    Set data = Range([A2], Cells(Rows.Count, "A").End(xlUp))

    'get unique values from split
    For Each cl In data
        For Each x In Split(cl, "|"): x = Trim(x)
            If Not Dic.exists(x) Then
                Dic.Add x, Nothing
                arrList.Add x
            End If
    Next x, cl

    Dic.RemoveAll        'clear dictionary

    arrList.Sort         'sort values
    If sortorder = xlDescending Then
        arrList.Reverse
    End If

    'add headers
    i = 2
    For Each x In arrList
        Cells(1, i).Value2 = x
        Dic.Add x, i: i = i + 1
    Next x
    'split values against headers
    For Each cl In data
        For Each x In Split(cl, "|"): x = Trim(x)
            Cells(cl.Row, Dic(x)).Value2 = x
    Next x, cl
End Sub

在这里测试