Excel VBA - 获取跨列的唯一条目列表并组合成唯一项目的单列

Question

我正在尝试将多个列中的唯一数据列表获取到单个列中。

我发现以下代码效果很好；

RanglFilterCopy, CopyToRange:=Range("B1"), Uniqe("A1:A6").AdvancedFilter Action:=xue:=True

来源是（感谢https://stackoverflow.com/users/495455/jeremy-thompson 发帖）： Quicker way to get all unique values of a column in VBA?

我的问题是，我不想被限制在一个设定的范围内（即我希望范围根据输入的数据是动态的），因为范围可能会发生变化，我想跨多个列捕获唯一值，不只是 1。

我认为我需要按照以下几行做一些事情，但真的迷失在 VBA 代码方面的起点。

1. 从列 (1) 中获取所有值并复制到新列 (x)
2. 从列 (2...n) 中获取所有值并将数据添加到列 (x) 中的下一个空单元格 注意：列选择不是顺序的（即可能是列 1、4、7 和9 而不是 1,2,3,4,5,6,7,8,9 如果这在能够循环通过范围方面有所不同）
3. 将所有列 (1...n) 复制到列 (x) 后，检查列 (x)，计算出唯一值并仅将这些唯一值传输到列 (y)
4. 最后一次检查列 (y) 以确保没有重复（如果有正确的话）
5. 清理并删除除表和列 (y) 中的原始源数据之外的所有内容，希望现在包含我的唯一值（即删除列 (x)）。

需要考虑的要点；

1. 数据包含在特定工作表的“表”中的“列”中 我的表中的列示例是 -> Range("Table1[StileCode]")
2. 我想在列 (y) 中指定起始单元格，以放置与源数据不同的工作表上的唯一值。
3. 添加到目标工作表和列的数据，即列 (y) 最好包含在工作表的“命名范围”中。
4. “命名范围”通过索引/匹配方案在源工作表的公式中使用（即我想要唯一值的原因）。

总结 我想基本上动态地动态创建一个唯一列表（或者当我选择运行代码时），它会及时捕获所有唯一值。

我知道这是一个很大的问题，但我们将不胜感激任何帮助/指导。

好的 - 做了一些功课，以下似乎可行，请不要笑，我不是 VBA 专家，所以我想代码很笨拙，很可能用更少的代码来实现。

任何建议将不胜感激。

我用 Sheet1 和 Sheet 2 创建了一个新工作簿。

数据在 Sheet1 的 A、B、C、D 和 E 列中。

代码如下；

Sub TestTheoryCopy()
    Dim sourceWS As Worksheet
    Dim targetWS As Worksheet
    Dim sourceValues As Range
    Dim targetRange As Range

    Set sourceWS = ThisWorkbook.Sheets("Sheet1")
    Set targetWS = ThisWorkbook.Sheets("Sheet2")

    Dim i As Integer

    Dim dataColA As Integer
    dataColA = 1

    Dim dataColC As Integer
    dataColC = 3

    Dim dataColE As Integer
    dataColE = 5

    Dim startRange As Range
    Dim ra As Range

    targetWS.Cells.Clear

    For i = dataColA To dataColA
        Set startRange = sourceWS.Range("A2").Offset(0, i - 1)
        Set ra = sourceWS.Range(startRange, sourceWS.Cells(Rows.Count, startRange.Column).End(xlUp))
        ra.Copy
        targetWS.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    Next i

    For i = dataColC To dataColC
        Set startRange = sourceWS.Range("A2").Offset(0, i - 1)
        Set ra = sourceWS.Range(startRange, sourceWS.Cells(Rows.Count, startRange.Column).End(xlUp))
        ra.Copy
        targetWS.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    Next i

    For i = dataColE To dataColE
        Set startRange = sourceWS.Range("A2").Offset(0, i - 1)
        Set ra = sourceWS.Range(startRange, sourceWS.Cells(Rows.Count, startRange.Column).End(xlUp))
        ra.Copy
        targetWS.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
    Next i

    targetWS.Activate

    RemoveBlankCells 'If blank cells are included I wanted to remove them from the dataset

    Dim FoundFromColumnsRangeA As Range
    Dim uniqueIDs As Range

    Set FoundFromColumnsRangeA = Sheets("Sheet2").UsedRange
    FoundFromColumnsRangeA.Columns(1).Select

    With Selection
        .AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True
    End With

    Set uniqueIDs = Sheets("Sheet2").UsedRange
    FoundFromColumnsRangeA.Columns(2).Select

    With Selection
        .AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("C2"), Unique:=True
    End With

    RemoveBlankCells

    Columns("A:B").EntireColumn.Delete

End Sub

Private Sub RemoveBlankCells()
'PURPOSE: Deletes single cells that are blank located inside a designated range
'SOURCE: www.TheSpreadsheetGuru.com

Dim ws As Worksheet
Dim rng As Range

Set ws = ThisWorkbook.Sheets("Sheet2")

'Store blank cells inside a variable
  On Error GoTo NoBlanksFound
    Set rng = ws.Range("A:A").SpecialCells(xlCellTypeBlanks)
  On Error GoTo 0

'Delete blank cells and shift upward
  rng.Rows.Delete Shift:=xlShiftUp

Exit Sub

'ERROR HANLDER
NoBlanksFound:
  MsgBox "No Blank cells were found"

End Sub

}

Answer 1

在这个时代，我会使用 Power Query / Get and Transform。将所有数据表拉入查询，删除除您感兴趣的一列之外的所有数据，追加查询并删除重复项。

如果数据发生变化，只需点击 Refresh All 按钮。中提琴。

Answer 2

这里有一些应该可以相当快地运行的代码。 如所写，表名称、工作表名称和要复制的特定列是硬编码的。

为了处理速度（通常比访问工作表更快），将数据读入变量数组。

Collection 对象用于删除重复项（测试并跳过空白）。可以使用Dictionary 对象，哪个更快取决于数据的大小。其他区别：

• 如果您有重复的键，Collection 对象会引发错误。
• Dictionary 对象有一个.Exists 方法
• Dictionary 对象需要早期或后期绑定到 Microsoft Scripting Runtime
• Collection 对象是本机 VBA。

希望这段代码能给你一些线索。

Option Explicit
Sub deDupe()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim cUniques As Collection
    Dim I As Long, J As Long
    Dim colArray
    Dim V

'Columns to include
' 1 = first column in table
colArray = Array(1, 3, 5) 'Note this will be zero-based array

'Change sheet names for data and results as needed
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 1) 'put first cell of unique list anyplace

'Read data into variant array for speed
vSrc = wsSrc.ListObjects("Table1").DataBodyRange

'Collect the unique values
Set cUniques = New Collection
On Error Resume Next 'Duplicate keys in .Add method --> error
For J = 0 To UBound(colArray)
    For I = 1 To UBound(vSrc)
        V = vSrc(I, colArray(J))
        If V <> "" Then
            cUniques.Add Item:=V, Key:=CStr(V)
        End If
    Next I
Next J
On Error GoTo 0

'create results array
ReDim vRes(1 To cUniques.Count, 1 To 1)
For I = 1 To UBound(vRes, 1)
    vRes(I, 1) = cUniques(I)
Next I

'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1), 1)
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .EntireColumn.AutoFit
End With

End Sub