Question

我有一本完整的字典。所有单词（360 000）都在一栏中。

我希望B列的所有单词都以“a”开头，C列的所有单词都以b开头...

我正在尝试做一个循环或某事......但是......这太长了。

任何提示？或者有人已经做过这个vba宏吗？

韩国社交协会，

斯特凡。

Answer 1

如果我们开始：

enter image description here

运行这个短宏：

Sub SeparateData()
    Dim N As Long, i As Long, NewCol As Long
    Dim M As Long
    N = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 1 To N
        NewCol = Asc(UCase(Left(Cells(i, 1).Value, 1))) - 63
        If Cells(1, NewCol).Value = "" Then
            M = 1
        Else
            M = Cells(Rows.Count, NewCol).End(xlUp).Row + 1
        End If
        Cells(M, NewCol).Value = Cells(i, 1).Value
    Next i
End Sub

将产生：

enter image description here

<强> 注：的

您可能需要在 NewCol 计算行中添加一些错误捕获逻辑。

修改＃1：

这个版本可能会稍快一些：

Sub SeparateDataFaster() Dim N As Long, i As Long, NewCol As Long Dim M As Long, time1 As Date, time2 As Date N = Cells(Rows.Count, 1).End(xlUp).Row time1 = Now Application.ScreenUpdating = False Application.Calculation = xlCalculationManual For i = 1 To N NewCol = Asc(UCase(Left(Cells(i, 1).Value, 1))) - 63 If Cells(1, NewCol).Value = "" Then M = 1 Else M = Cells(Rows.Count, NewCol).End(xlUp).Row + 1 End If Cells(M, NewCol).Value = Cells(i, 1).Value Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic time2 = Now MsgBox time1 & vbCrLf & time2 End Sub

Answer 2

你可以尝试这样的事情。对于360k记录，它需要大约20秒。

要创建测试数据，请使用此子目录：

Sub FillTestData()

Dim t As Long
Dim lng As Integer
Dim text As String

'Start = Timer

For t = 1 To 360000
text = vbNullString
lng = 5 * Rnd + 10
    For i = 1 To lng
    Randomize
    text = text & Chr(Int((26 * Rnd) + 65))
    Next i
    Cells(t, 1) = text
Next t

'Debug.Print Timer - Start

End Sub

分开：

Sub sep()

'Start = Timer
Dim ArrWords() As Variant
Dim Row_ As Long

LastRow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
ArrWords = Range("A1:A" & LastRow) 'all data from column A to array

For i = 65 To 90 ' from A to Z
    Row_ = 1
    For j = LBound(ArrWords, 1) To UBound(ArrWords, 1)
        If Asc(UCase(ArrWords(j, 1))) = i Then
        Cells(Row_, i - 63) = ArrWords(j, 1)
        Row_ = Row_ + 1
        End If
    Next j
Next i

'other than a[A]-z[Z]
Row_ = 1
For j = LBound(ArrWords, 1) To UBound(ArrWords, 1)
    If Asc(UCase(ArrWords(j, 1))) < 65 Or Asc(UCase(ArrWords(j, 1))) > 90 Then
        Cells(Row_, 28) = ArrWords(j, 1)
        Row_ = Row_ + 1
    End If
Next j

'Debug.Print Timer - Start
End Sub

Answer 3

您可以输入以下公式：

对于B栏中的字母A： =IF(UPPER(LEFT(A1,1))="A",A1,"")

C列中的字母B： =IF(UPPER(LEFT(A1,1))="B",A1,"")

对字母C，D等重复相同的操作..

Answer 4

你可以尝试：

For i = 1 To Cells(Rows.count, 1).End(xlUp).Row
    Range(UCase(Left$(Cells(i, 1).Text, 1)) & Rows.count).Offset(0, 1).End(xlUp).Offset(IIf(Range(UCase(Left$(Cells(i, _
    1).Text, 1)) & Rows.count).Offset(0, 1).End(xlUp).Row = 1, 0, 1), 0).Value = Cells(i, 1).Text
Next i

通过执行以下操作，使用单词的第一个字母构建目标地址：

循环遍历A列中的每个单元格
获取该单元格的第一个字母并将其转换为大写
查找以该字母开头的列中的最后一个单元格
向右移动1列
上去，直到我们点击最后一行数据
如果最后一行不是第1行，则向下移动另一行（下一个空白单元格）
为此单元格提供与我们正在评估的A列中的单元格相同的值

VBA：如何将每列完整字典转换为每个字母一列？

4 个答案: