VBA to Extract unique values from multiple columns in to two column

[SteynBS]

I need unique values in 2 columns to be pasted into another sheet in 2 columns.

I used this one but it pastes the values into 1 column

Sub ManyColDupes()
Dim MyDict As Object, InputRange As Range, OutputCol As Range, z As Variant, c As Variant

Set MyDict = CreateObject("Scripting.Dictionary")
Set InputRange = Sheets("Sheet6").Range("D1:BS1,CC1")
Set OutputCol = Sheets("Sheet7").Range("X1")

On Error Resume Next
For Each c In InputRange
For Each z In Range(c, c.Offset(Rows.Count - 1).End(xlUp))
If z <> "" Then MyDict(CStr(z)) = 1
Next z
Next c

OutputCol.Resize(MyDict.Count, 1).Value = WorksheetFunction.Transpose(MyDict.keys)

End Sub

Example
Column D must be pasted into the other sheet in Column B, and Column E needs to be pasted in the other sheet in Column C

Vendor Name Site
Premier Site 1
Premier Site 2
Nativa X
Cosmic Fashion Site C
MC Site X
MC Site Y

 

[LazyBug]

If I understood you correctly.

Sub ManyColDupes_modified()
Dim InputRange, c As Range

    Set InputRange = Worksheets("Sheet6").Range("D1:D" & Range("D1").End(4).Row)
    With CreateObject("Scripting.Dictionary")
        For Each c In InputRange
            .Item(c(1, 2).Value) = c.Value
        Next c
   
        Worksheets("Sheet7").Range("B1").Resize(.Count, 2) = Application.Transpose(Array(.items, .keys))
    End With
End Sub

 

[SteynBS]

If I understood you correctly.

Sub ManyColDupes_modified()
Dim InputRange, c As Range

    Set InputRange = Worksheets("Sheet6").Range("D1:D" & Range("D1").End(4).Row)
    With CreateObject("Scripting.Dictionary")
        For Each c In InputRange
            .Item(c(1, 2).Value) = c.Value
        Next c
  
        Worksheets("Sheet7").Range("B1").Resize(.Count, 2) = Application.Transpose(Array(.items, .keys))
    End With
End Sub

You sir, are on the right path. Thank you. It did not copy all the relevant data for some reason.
This is the info I have ons sheet6

This is what was copied to Sheet7 - Brunel Labs has 1 site correct, It did not copy Cosmederm, Creme Classique or DSV and some others. Transpharm has 2 sites copied correctly, but ICIM has 2 sites, it only copied the 1.

 

[LazyBug]

How about

Sub ManyColDupes_mod2()
Dim InputRange As Range, c As Range, j, i&, k
 
    Set InputRange = Sheets("Sheet6").Range("D1:D" & Cells(1, 5).End(4).Row)
    With CreateObject("Scripting.Dictionary")
        For Each c In InputRange
            j = c.Value & c(1, 2).Value
            .Item(j) = Array(c.Value, c(1, 2).Value)
        Next c
    i = 1
        For Each k In .Keys
            Sheets("Sheet7").Cells(i, 2).Resize(, 2) = Array(.Item(k)(0), .Item(k)(1))
            i = i + 1
        Next
    End With
End Sub

 

[SteynBS]

How about

Sub ManyColDupes_mod2()
Dim InputRange As Range, c As Range, j, i&, k
 
    Set InputRange = Sheets("Sheet6").Range("D1:D" & Cells(1, 5).End(4).Row)
    With CreateObject("Scripting.Dictionary")
        For Each c In InputRange
            j = c.Value & c(1, 2).Value
            .Item(j) = Array(c.Value, c(1, 2).Value)
        Next c
    i = 1
        For Each k In .Keys
            Sheets("Sheet7").Cells(i, 2).Resize(, 2) = Array(.Item(k)(0), .Item(k)(1))
            i = i + 1
        Next
    End With
End Sub

Bingo, Works a charm. Thank you so much.

 

[LazyBug]

You are welcome.

 

[SteynBS]

Bingo, Works a charm. Thank you so much.

@LazyBug you where a big help, thank you. I have just one last question. I tried to figure it out now, but I don't seem to get it. I would like to include 1 more column. Column C

If I use your code as is, and change the value ".Resize(, 2)" to 3 it gives me a #N/A in the 3rd column.

The Vendor Number and Vendor Name will always have corresponding values for example 190 will always be Brunel Labs and 4325 will always be MIC.

Is there a way to include this without making major changes to your code?

 

[LazyBug]

I have just one last question.

Let's say our procedure should insert cell values from one row into array inside each of dictionary items. Since the number of cells you need from every row is three, for every unique row array is structured for three elements. So now to unload these ones to a worksheet we can use Resize property with parameter ColumnSize=3:

Sub sbs3()
Dim j, r As Range, c As Range, i&

    Set r = Sheets("Sheet6").Range("D1:D" & Cells(1, 5).End(4).Row)
    With CreateObject("Scripting.Dictionary")
        For Each c In r
            j = c.Value & c(1, 2).Value
            .Item(j) = Array(c(1, 0).Value, c.Value, c(1, 2).Value)
        Next c
    i = 1
        For Each j In .Keys
            Sheets("Sheet7").Cells(i, 2).Resize(, 3) = Array(.Item(j)(0), .Item(j)(1), .Item(j)(2))
            i = i + 1
        Next j
    End With
End Sub

 

[SteynBS]

Let's say our procedure should insert cell values from one row into array inside each of dictionary items. Since the number of cells you need from every row is three, for every unique row array is structured for three elements. So now to unload these ones to a worksheet we can use Resize property with parameter ColumnSize=3:

Sub sbs3()
Dim j, r As Range, c As Range, i&

    Set r = Sheets("Sheet6").Range("D1:D" & Cells(1, 5).End(4).Row)
    With CreateObject("Scripting.Dictionary")
        For Each c In r
            j = c.Value & c(1, 2).Value
            .Item(j) = Array(c(1, 0).Value, c.Value, c(1, 2).Value)
        Next c
    i = 1
        For Each j In .Keys
            Sheets("Sheet7").Cells(i, 2).Resize(, 3) = Array(.Item(j)(0), .Item(j)(1), .Item(j)(2))
            i = i + 1
        Next j
    End With
End Sub

Wish I could give you a Bells. Thank you, I really do appreciate it.

 

[SteynBS]

Let's say our procedure should insert cell values from one row into array inside each of dictionary items. Since the number of cells you need from every row is three, for every unique row array is structured for three elements. So now to unload these ones to a worksheet we can use Resize property with parameter ColumnSize=3:

Sub sbs3()
Dim j, r As Range, c As Range, i&

    Set r = Sheets("Sheet6").Range("D1:D" & Cells(1, 5).End(4).Row)
    With CreateObject("Scripting.Dictionary")
        For Each c In r
            j = c.Value & c(1, 2).Value
            .Item(j) = Array(c(1, 0).Value, c.Value, c(1, 2).Value)
        Next c
    i = 1
        For Each j In .Keys
            Sheets("Sheet7").Cells(i, 2).Resize(, 3) = Array(.Item(j)(0), .Item(j)(1), .Item(j)(2))
            i = i + 1
        Next j
    End With
End Sub

@LazyBug As I work on this sheet and build it - more information is required. My columns are a bit re-arranged.

So the columns to use to filter for unique values will now be B,C,D,E and maybe F, but now I need to copy column B:H and maybe 2 extra columns to my other sheet.

On you previous solution I could filter on 3 columns. Is there anyway to filter now on 4 or 5 and copy 9 columns into a new sheet?