Excel VBA - 获取跨列的唯一条目列表并将其合并为一列唯一项

Question

我正在尝试将多列中的唯一数据列表放入单列中。

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

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

其来源是（感谢https://stackoverflow.com/users/495455/jeremy-thompson发布）： 在 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 和 Transform。 将所有数据表拉入查询，删除除您感兴趣的一列之外的所有数据表，附加查询并删除重复项。

如果数据发生变化，只需点击“全部刷新”按钮。 中提琴。

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