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

Question

我有一份报告，我需要将特定范围的短语分成单个单词并叠加它们删除所有副本。

我尝试自动化将是一个三步过程：

1. 打破空格之间的文字
2. 将所有内容堆叠到新工作表中的单个列中
3. 删除重复项

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

步骤1：使用＆＃34; texto到列＆＃34;打破短语

第2步（堆叠列）：不知道，我迷失在这里

第3步：使用＆＃34;删除重复项＆＃34;好吧，删除重复的数据

我可以为第1步和第3步处理VBA，但我不知道如何为第2步进行代码自动化。任何想法我该如何实现？

Answer 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)。

Answer 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

Answer 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