0

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

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

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

}

4

2 回答 2

1

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

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

于 2018-03-28T07:11:20.057 回答
0

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

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

该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
于 2018-03-28T12:14:16.137 回答