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

Question

I am trying to get a list of unique data from multiple columns into a single column.

I found the following code which works great;

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

Source of this was (and thank you to https://stackoverflow.com/users/495455/jeremy-thompson for posting): Quicker way to get all unique values of a column in VBA?

My issue is, I don't want to be limited to a set range (ie I want the range to be dynamic based on the entered data) as the range may change and I want to capture unique values across multiple columns, not just 1.

I am thinking that I need to do something along the following lines but really am lost where to start in terms of VBA code.

1. Get all values from Column (1) and copy to a new Column (x)
2. Get all values from Column (2...n) and add the data to the next empty cell in Column (x) NOTE: Column selection is not sequential (ie May be Column 1, 4, 7 and 9 rather than 1,2,3,4,5,6,7,8,9 if that makes a difference in terms of being able to loop through a range)
3. Once all Columns (1...n) are copied across to Column (x), check Column (x), work out the unique values and transfer only these unique values to Column (y)
4. Check Column (y) a final time to ensure there are no duplicated (if there are correct them)
5. Clean up and get rid of everything except the original source data within the Table and Column (y) which hopefully now contains my unique values (ie get rid of Column (x)).

Points to consider;

1. The data is contained in "Columns" within a "Table" on a specific worksheet Example of a Column within my Table is -> Range("Table1[StileCode]")
2. I want to specify the start cell in Column (y) to place the unique values which will be on a different worksheet to the source data.
3. The data added to the target sheet and column, ie Column (y) will ideally be contained in a "Named Range" on the worksheet.
4. The "Named Range" is used in formulas on the source worksheet via an index/match scenario (ie the reason I want unique values).

Summary I want to basically dynamically create a unique list on the fly (or when I choose to run the code) which captures all the unique values at that point in time.

I know this is a big ask but any assistance/guidance would be greatly appreciated.

OK - Done a little homework and the following seems to work, please don't laugh, I am no VBA expert so I am imagining that the code is clunky and could most probably be achieved with less code.

Any suggestions would be appreciated.

I created a new workbook with Sheet1 and Sheet 2.

The data is in columns A, B, C, D and E of Sheet1.

Code as follows;

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

In this day and age I would use Power Query / Get and Transform. Pull all the data tables into queries, delete all but the one column you are interested in, append the queries and delete duplicates.

If the data changes, just hit the Refresh All button. Viola.

Answer 2

Here is some code that should run reasonably quickly. As written, the Table name, worksheet names, and the particular columns to copy are hard coded.

The data is read into a variant array for speed of processing (usually faster than accessing the worksheets).

The Collection object is used to remove duplicates (and blanks are tested for and skipped). One could use the Dictionary object, and which would be faster depends on the size of the data. Other differences:

• The Collection object throws an error if you have a duplicate key.
• The Dictionary object has a .Exists method
• The Dictionary object requires early or late binding to Microsoft Scripting Runtime
• The Collection object is native VBA.

Hopefully, this code will give you some clues.

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