Excel 将短语分解成单个单词，然后将所有内容堆叠成一列

我有一份报告，我需要将特定范围的短语分解成单个单词，并将它们堆叠起来，删除所有重复项

这将是一个三步流程，我正在尝试实现自动化：

在空格之间打断单词

将所有内容堆叠到新工作表上的单个列中

删除重复项

我自己不是程序员，所以要想将手动操作转变为自动操作，我会：

步骤1：使用“texto to column”来打断短语

步骤2（堆栈列）：不知道，我在这里迷路了

步骤3：使用“删除重复项”很好地删除重复的数据

我可以处理步骤1和3的VBA，但我不知道如何使步骤2的代码自动化。有什么办法可以做到吗

---

要回答问题2，请使用嵌套循环：

i=1
j=1
计数器=1
做
做
如果ActiveSheet.Cells（i，j）=“那么
j=1
退出Do
如果结束
ActiveSheet.Cells（计数器，15）=ActiveSheet.Cells（i，j）
计数器=计数器+1
j=j+1
环
i=i+1
如果ActiveSheet.Cells（i，j）=“”，则退出Do
循环

---

这假设您希望在O列上执行“删除重复项”的目标字段。这还假设您正确地

TRIM

文本到列的结果（似乎所有值都被一个空格分隔）。另外，我不知道您的工作表的名称，因此根据需要将

ActiveSheet

替换为

sheets（destination\u sheet）

。

您可以从剪贴板获取文本，并将空格替换为新行（未测试）：

---

这里有一个宏可以帮你完成。我仍然建议您自己尝试到这里，但至少您可以使用F8逐步了解它的工作原理，一行一行：

Sub transposeUnique()
Dim mainWS As Worksheet, newWS As Worksheet
Dim groupRng As Range, rng As Range, cel As Range

Set mainWS = Sheets("Sheet1")    ' Change the name as required
Set newWS = Sheets("Sheet2")
With mainWS
    Set groupRng = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
    groupRng.Select
    newWS.Range("A2:A" & groupRng.Rows.Count + 1).Value = groupRng.Value
    Set groupRng = newWS.Range(newWS.Cells(2, 1), newWS.Cells(newWS.Cells(newWS.Rows.Count, 1).End(xlUp).Row, 1))
    groupRng.TextToColumns Destination:=newWS.Range("H2"), DataType:=xlDelimited, _
                           TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Space:=True
End With

Dim numRows As Long

With newWS
    numRows = .Cells(.Rows.Count, 8).End(xlUp).Row    ' assuming you pasted the Text to Column to col. H

    Dim lastCol As Long, nextRow As Long
    nextRow = 2
    For i = 2 To numRows
        lastCol = .Cells(i, .Columns.Count).End(xlToLeft).Column
        Set rng = .Range(.Cells(i, 8), .Cells(i, lastCol))
        rng.Copy
        .Range("G" & nextRow).PasteSpecial Transpose:=True
        nextRow = .Cells(.Rows.Count, 7).End(xlUp).Row + 1
    Next i

    .Range("G:G").RemoveDuplicates Columns:=1, Header:=xlNo
End With                     'newWS

End Sub

---

你有主意了！打开宏录制器录制代码，然后发回此处。1） 文本到列2）复制每一行，并粘贴特殊转置（这会将“A B C”向下粘贴三行，而不是跨三列），3）删除重复项。然后停止录音。您将有一个非常特定的代码，因此请尝试并使用它。从那里，如果你被卡住了，发布你的代码，我们可以帮助你。嘿@BruceWayne，谢谢你的回答。我已经更新了我的问题。我可以通过录制宏并在VBA编辑器中进行细微更改来处理步骤1和步骤3的宏记录，但在步骤2，事情变得模糊。断开的单词中的列数将取决于短语中存在的单词数。如何使自动化不依赖于特定数量的os列？有什么想法吗？是的，当然有。你会想调查的。基本上，当您将文本添加到列时，您将拥有（比方说）第1行、第3列。第2行，6列。第3行，5列。您只需要遍历每一行，获取“column1tox”数据，将特殊转置复制/粘贴到目标列。如果您是VBA新手，这可能有点让人望而生畏，但是如果您能运行一些代码，我很乐意帮助您解决任何问题。

Sub transposeUnique()
Dim mainWS As Worksheet, newWS As Worksheet
Dim groupRng As Range, rng As Range, cel As Range

Set mainWS = Sheets("Sheet1")    ' Change the name as required
Set newWS = Sheets("Sheet2")
With mainWS
    Set groupRng = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
    groupRng.Select
    newWS.Range("A2:A" & groupRng.Rows.Count + 1).Value = groupRng.Value
    Set groupRng = newWS.Range(newWS.Cells(2, 1), newWS.Cells(newWS.Cells(newWS.Rows.Count, 1).End(xlUp).Row, 1))
    groupRng.TextToColumns Destination:=newWS.Range("H2"), DataType:=xlDelimited, _
                           TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Space:=True
End With

Dim numRows As Long

With newWS
    numRows = .Cells(.Rows.Count, 8).End(xlUp).Row    ' assuming you pasted the Text to Column to col. H

    Dim lastCol As Long, nextRow As Long
    nextRow = 2
    For i = 2 To numRows
        lastCol = .Cells(i, .Columns.Count).End(xlToLeft).Column
        Set rng = .Range(.Cells(i, 8), .Cells(i, lastCol))
        rng.Copy
        .Range("G" & nextRow).PasteSpecial Transpose:=True
        nextRow = .Cells(.Rows.Count, 7).End(xlUp).Row + 1
    Next i

    .Range("G:G").RemoveDuplicates Columns:=1, Header:=xlNo
End With                     'newWS

End Sub