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

【问题标题】：Break phrases into single words and then stack everything into one single column将短语分解为单个单词，然后将所有内容堆叠成一列
【发布时间】：2017-03-10 07:38:37
【问题描述】：

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

这将是一个我试图自动化的三步过程：

用空格分隔单词
将所有内容堆叠到新工作表上的一列中
删除重复项

我自己不是程序员，所以尝试将手动操作变成自动化操作我会：

第 1 步：使用“texto to column”来分词

第 2 步（堆叠列）：不知道，我迷路了

第3步：使用“remove duplicates”很好，删除重复数据

我可以处理第 1 步和第 3 步的 VBA，但我不知道如何使第 2 步的代码自动化。有什么想法可以实现吗？

【问题讨论】：

你明白了！打开宏记录器记录代码，然后在这里发回。 1）文本到列 2）复制每一行，并粘贴特殊的转置（这会将“A B C”粘贴到三行，而不是跨三列），3）删除重复项。然后停止录音机。你会有一个非常具体的代码，所以试试remove the use of .Select/.Activate。从那里，如果您遇到困难，请发布您拥有的代码，我们可以提供帮助。
嘿@BruceWayne，感谢您的回答。我已经更新了我的问题。我可以通过录制宏并在 VBA 编辑器中进行细微更改来处理步骤 1 和 3 的宏记录，但是在步骤 2 中事情变得模糊。断开单词的列数将取决于短语中存在多少单词。如何使自动化不依赖于特定数量的 os 列？有什么想法吗？
是的，当然。您需要查看create a dynamic range。本质上，当您完成文本到列时，您将拥有（比方说）第 1 行、第 3 列。第 2 行，6 列。第 3 行，第 5 列。您只想遍历每一行，获取“第 1 列到第 x 列”数据，将特殊转置复制/粘贴到您的目标列。如果您是 VBA 新手，这可能有点令人生畏，但如果您可以编写一些代码，我将很乐意帮助解决您遇到的任何问题。

标签： excel vba

【解决方案1】：

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

i = 1 j = 1 counter = 1 Do Do If ActiveSheet.Cells(i, j) = "" Then j = 1 Exit Do End If ActiveSheet.Cells(counter, 15) = ActiveSheet.Cells(i, j) counter = counter + 1 j = j + 1 Loop i = i + 1 If ActiveSheet.Cells(i, j) = "" Then Exit Do Loop

这假设您希望在其上执行“删除重复项”的目标字段是 O 列。这还假设您正确地将文本 TRIM 到列结果（似乎您的值都由一个空格分隔）。另外，我不知道您的床单名称，因此请根据需要将ActiveSheet 替换为Sheets(destination_sheet)。

【讨论】：

【解决方案2】：

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

[A:A].Copy
With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' this is late bound MSForms.DataObject
    .GetFromClipboard
    Application.CutCopyMode = False
    .SetText Replace(.GetText, " ", vbCrLf)
    .PutInClipboard
End With
[G1].PasteSpecial 
[G:G].RemoveDuplicates 1

【讨论】：

【解决方案3】：

这里有一个宏应该可以帮到你。我仍然建议您自己尝试到这里，但至少，您可以使用 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

【讨论】：