Extract Unique Values From Multiple Columns With Macro

Question

I have a list of codes in A and the image links in B and C.

What i want to do is remove the duplicates and arrange the unique links in a single column and give them a series name with incrementing no code_1 before image link 1 and code_2 before link 2 as shown in the picture.

I am trying this code to delete the duplicates but clueless about how to put the name before the link.

Sub tgr()

    Dim wb As Workbook
    Dim wsDest As Worksheet
    Dim rData As Range
    Dim rArea As Range
    Dim aData As Variant
    Dim i As Long, j As Long
    Dim hUnq As Object

    'Prompt to select range.  Uniques will be extracted from the range selected.
    'Can select a non-contiguous range by holding CTRL
    On Error Resume Next
    Set rData = Application.InputBox("Select range of names where unique names will be extracted:", "Data Selection", Selection.Address, Type:=8)
    On Error GoTo 0
    If rData Is Nothing Then Exit Sub   'Pressed cancel

    Set hUnq = CreateObject("Scripting.Dictionary")
    For Each rArea In rData.Areas
        If rArea.Cells.Count = 1 Then
            ReDim aData(1 To 1, 1 To 1)
            aData(1, 1) = rArea.Value
        Else
            aData = rArea.Value
        End If

        For i = 1 To UBound(aData, 1)
            For j = 1 To UBound(aData, 2)
                If Not hUnq.Exists(aData(i, j)) And Len(Trim(aData(i, j))) > 0 Then hUnq(Trim(aData(i, j))) = Trim(aData(i, j))
            Next j
        Next i
    Next rArea

    Set wb = rData.Parent.Parent    'First parent is the range's worksheet, second parent is the worksheet's workbook
    Set wsDest = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
    wsDest.Range("A1").Resize(hUnq.Count).Value = Application.Transpose(hUnq.Items)

End Sub

Possible duplicate of https://stackoverflow.com/questions/36044556/quicker-way-to-get-all-unique-values-of-a-column-in-vba — Rno, Dec 13 '19 at 12:00
I am able to remove the duplicate however the first column needs to be unique and rename with _1 this is not mentioned in the duplicate question — Sameer Farooqui, Dec 13 '19 at 12:04

pgSystemTester · Answer 1 · 2019-12-13T12:35:44.633

0

This custom VBA function would create the desired result of getting the SKU code. I broke it up to show how to get each position.

Function Drop_Bucks(inputText As String) As String
Dim beginSpot As Long, endSpot As Long

    'Finds last /
    beginSpot = InStrRev(inputText, "/", -1, vbTextCompare) + 1
    'Finds jpg
    endSpot = InStrRev(inputText, ".jpg", -1, vbTextCompare)

Drop_Bucks = Replace(Mid(inputText, beginSpot, endSpot - beginSpot), "-", "_")


End Function

As a followup, you could also create the sku without VBA. If you put this formula in cell c4 with a sku in d4. It should do without macro.

=SUBSTITUTE(SUBSTITUTE(LEFT(SUBSTITUTE(SUBSTITUTE(RIGHT(SUBSTITUTE(d4, "/",REPT("?", 999)), 999),"?",""), ".jpg",REPT("?", 999)), 999),"?",""),"-","_")

edited Dec 13 '19 at 12:35

answered Dec 13 '19 at 12:21

pgSystemTester

8,979
2
23
49

unable to achieve the desired result, sharing an example file with you with some test data, can you implement the same here - https://drive.google.com/file/d/1jqPn0-ptTJo4OyuA5FMUgctsITPDF_ps/view?usp=sharing, also i am not extracting the sku code from the link you can refer the attached file you will get the context – Sameer Farooqui Dec 13 '19 at 12:37
@SameerFarooqui I was under the impression the duplicate issue was resolved. Even so, the custom function and excel function will get your de-duplicated range string correct. – pgSystemTester Dec 13 '19 at 16:12

JosephC · Answer 2 · 2019-12-13T18:56:50.860

This builds a list of all the item duplicates and all. It will then uses the function Range.RemoveDuplicates to remove duplicates of the SKU Code in combination with the URL within the range.

Option Explicit

Sub Test()

    Dim oCurSourceSheet As Worksheet
    Set oCurSourceSheet = Sheet1 ' What sheet is your Source Data on?
    Dim oSourceRow As Long    ' Which Row/Column does your data start on?
    oSourceRow = 2           ' First Row of First "Link"
    Dim oSourceCol As Long
    oSourceCol = 2           ' First Column of First "Link"

    Dim oOutputRange As Range
    Set oOutputRange = Sheet1.Range("A10") ' What Sheet/Cell do you want the output to start on/in?

    Dim oCurRow As Long ' Row counter for Output
    oCurRow = 1

    Dim oCurSourceRow As Long
    Dim oCurSourceCol As Long
    For oCurSourceRow = oSourceRow To oCurSourceSheet.UsedRange.Rows.Count
        For oCurSourceCol = oSourceCol To oCurSourceSheet.UsedRange.Columns.Count
            oOutputRange.Cells(oCurRow, 1) = oCurSourceSheet.Cells(oCurSourceRow, 1) & "_" & oCurSourceCol - 1
            oOutputRange.Cells(oCurRow, 2) = oCurSourceSheet.Cells(oCurSourceRow, oCurSourceCol)
            oCurRow = oCurRow + 1
        Next
    Next

    'Reize range from output's starting cell & remove duplicates
    Set oOutputRange = oOutputRange.Resize(oCurRow - 1, 2)
    oOutputRange.RemoveDuplicates Columns:=Array(1, 2)

End Sub

unable to implement the code, sharing the sample file https://drive.google.com/file/d/1jqPn0-ptTJo4OyuA5FMUgctsITPDF_ps/view . Can you help putting it together — Sameer Farooqui, Dec 13 '19 at 18:30
Why exactly can you not implement this code? What issue are you having? — JosephC, Dec 13 '19 at 18:39
runtime error - Set oOutputRange = oOutputRange.Resize(oCurRow - 1, 2) — Sameer Farooqui, Dec 13 '19 at 18:41
Updated Code, was overwriting source row & column variables. — JosephC, Dec 13 '19 at 18:57

score 0 · Answer 3 · answered Dec 13 '19 at 15:00

This may helps you:

Option Explicit

Sub TEST()

    Dim LastRow As Long, i As Long, LastRow2 As Long
    Dim arr As Variant

    With ThisWorkbook.Worksheets("Sheet1")

        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        .Range("$A$2:$C$" & LastRow).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo

        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        arr = .Range("A2:C" & LastRow)

        For i = LBound(arr) To UBound(arr)

            LastRow2 = .Cells(.Rows.Count, "E").End(xlUp).Row

            .Range("E" & LastRow2 + 1).Value = arr(i, 1) & "_1"
            .Range("F" & LastRow2 + 1).Value = arr(i, 2)

        Next i

        For i = LBound(arr) To UBound(arr)

            LastRow2 = .Cells(.Rows.Count, "E").End(xlUp).Row

            .Range("E" & LastRow2 + 1).Value = arr(i, 1) & "_2"
            .Range("F" & LastRow2 + 1).Value = arr(i, 3)

        Next i

    End With

End Sub

unable to implement the code, sharing the sample file drive.google.com/file/d/1jqPn0-ptTJo4OyuA5FMUgctsITPDF_ps/view . Can you help putting it together — Sameer Farooqui, Dec 13 '19 at 18:30

FaneDuru · Answer 4 · 2019-12-13T19:38:59.390

Try this, please: I adapted your code. The Dictionary is used just like a tool for avoiding duplicate values (due to the fact it exists...). Everything works in memory and should be very fast:

    Option Base 1

    Sub tgr_bis()
    Dim wb As Workbook, rData As Range, wsDest As Worksheet, rArea As Range
    Dim aData As Variant, aDataSorted() As String
    Dim i As Long, hUnq As Scripting.Dictionary, nrColumns As Long

    On Error Resume Next
    Set rData = Application.InputBox("Select range of names where unique names will be extracted:", "Data Selection", Selection.Address, Type:=8)
    On Error GoTo 0
    If rData Is Nothing Then Exit Sub   'Pressed cancel

    'Debug.Print rData.Columns.Count: Stop
    If rData.Columns.Count > 6 Then MsgBox "More then 6 columns..." & vbCrLf & _
                                         "Please select only six columns and run the procedure again", vbInformation, _
                                         "Too many columns": Exit Sub
    nrColumns = rData.Columns.Count
    Set hUnq = CreateObject("Scripting.Dictionary")
    For Each rArea In rData.Areas
        If rArea.Cells.Count = 1 Then
            ReDim aData(1 To 1, 1 To 1)
            aData(1, 1) = rArea.value
        Else
            aData = rArea.value
        End If
        ReDim aDataSorted(nrColumns, 1)
        Dim k As Long
        k = 1
        For i = 1 To UBound(aData, 1)
                If Not hUnq.Exists(aData(i, 1)) And Len(Trim(aData(i, 1))) > 0 Then
                    aDataSorted(1, k) = aData(i, 1): aDataSorted(2, k) = aData(i, 2): aDataSorted(3, k) = aData(i, 3)
                    Select Case nrColumns
                        Case 4
                            If aData(i, 4) <> "" Then aDataSorted(4, k) = aData(i, 4)
                        Case 5
                            If aData(i, 4) <> "" Then aDataSorted(4, k) = aData(i, 4)
                            If aData(i, 5) <> "" Then aDataSorted(5, k) = aData(i, 5)
                        Case 6
                            If aData(i, 4) <> "" Then aDataSorted(4, k) = aData(i, 4)
                            If aData(i, 5) <> "" Then aDataSorted(5, k) = aData(i, 5)
                            If aData(i, 6) <> "" Then aDataSorted(6, k) = aData(i, 6)
                        Case > 6
                           MsgBox "Too many selected columns!": Exit Sub
                    End Select

                    k = k + 1
                    ReDim Preserve aDataSorted(nrColumns, k)
                    hUnq(Trim(aData(i, 1))) = Trim(aData(i, 1))
                End If
        Next i
    Next rArea

    'Process the new array in order to be tansformed in what is needed:
    Dim finalCol() As String
    k = k - 1: Z = 1
     ReDim finalCol(2, Z)
     Dim lngIndex As Long
     Dim totalRows As Long

    For i = 1 To k
        lngIndex = 1
        finalCol(1, Z) = aDataSorted(1, i) & "_" & lngIndex: lngIndex = lngIndex + 1: _
                                finalCol(2, Z) = aDataSorted(2, i): totalRows = totalRows + 1
        Z = Z + 1: ReDim Preserve finalCol(2, Z)
        finalCol(1, Z) = aDataSorted(1, i) & "_" & lngIndex: lngIndex = lngIndex + 1: _
                                finalCol(2, Z) = aDataSorted(3, i): totalRows = totalRows + 1
        Z = Z + 1: ReDim Preserve finalCol(2, Z)
        If nrColumns < 4 Then GoTo EndLoop
        If aDataSorted(4, i) <> "" Then finalCol(1, Z) = aDataSorted(1, i) & "_" & lngIndex: _
                    lngIndex = lngIndex + 1: finalCol(2, Z) = aDataSorted(4, i): totalRows = totalRows + 1: _
                    Z = Z + 1: ReDim Preserve finalCol(2, Z)
        If nrColumns < 5 Then GoTo EndLoop
        If aDataSorted(5, i) <> "" Then finalCol(1, Z) = aDataSorted(1, i) & "_" & lngIndex: _
                    lngIndex = lngIndex + 1: finalCol(2, Z) = aDataSorted(5, i): totalRows = totalRows + 1: _
                    Z = Z + 1: ReDim Preserve finalCol(2, Z)
        If nrColumns < 6 Then GoTo EndLoop
        If aDataSorted(6, i) <> "" Then finalCol(1, Z) = aDataSorted(1, i) & "_" & lngIndex: _
                    lngIndex = lngIndex + 1: finalCol(2, Z) = aDataSorted(6, i): totalRows = totalRows + 1: _
                    Z = Z + 1: ReDim Preserve finalCol(2, Z)
EndLoop:
    Next i

    Set wb = rData.Parent.Parent
    Set wsDest = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))

    wsDest.Range("A1:B" & totalRows) = Application.Transpose(finalCol)
End Sub

'A reference to "Microsoft Scripting Runtime" must be added. Otherwise, you can declare hUnq As Object... And do not forget to have Option Base on tot of the module where this code exists. It is necessary to work with the way you built your initial code.

Edited: I adapted the code to accept up to six columns as you suggested. Please give it a try. But it only check the unique SKU Code and select the first occurrence. If the other occurrences appear, the will not be considered even if they have different strings on its row. The code can be adapted to work also from this point of view, but now I think is your turn to make some tests...

@Sameer Farooqui: Sorry, I forgot to tell you about an issue: You can use your previous declaration `Dim hUnq As Object` or do what I did (and I forgot to specify), respectively, add a reference to "Microsoft Scripting Runtime". In this way you will have access to the object properties/methods. — FaneDuru, Dec 13 '19 at 17:16
@Sameer Farooqui: The code tried to continue your way of working/coding. It is just a way to rapidly solve the problem. I mean, it works for three selected columns and the code must be adapted to warn somehow if the user selects more the 3. The code can also avoid using of Scripting.Dictionary in order to select unique strings, of course. It is a kind of didactic approach in order to make you understand what is to be done in order to accomplish what you want starting from what you have. — FaneDuru, Dec 13 '19 at 17:20
Yes you are right, when i am selecting more than 3 columns it is not working can you help here — Sameer Farooqui, Dec 13 '19 at 17:31
@Sameer Farooqui: The code can be easily made to do that. I will edit the code and add another row. But, do you think that you will need more then 3 columns? In your real life, it is possible to have more then three columns? If yes, the code can be also adapted, but you stated your request in a different way... Does the code work as expected after adding the suggested reference? — FaneDuru, Dec 13 '19 at 17:40
Yes the code is working, but it is only limited to 3 columns 1 for sku and rest two for links when i am selecting the third column while specifying the range it is only reading the first and 2nd column — Sameer Farooqui, Dec 13 '19 at 17:46
Let us [continue this discussion in chat](https://chat.stackoverflow.com/rooms/204220/discussion-between-sameer-farooqui-and-faneduru). — Sameer Farooqui, Dec 13 '19 at 17:56
@Sameer Farooqui: But you did not ask for such a thing! This will also involve "Code_1", "Code_2", "Code_3" and so on, for an indefinite number of columns. The code can be adapted to do whatever is necessary but we here help people to correct their mistakes, improve the code they tried and help them learning something... And I will also like to emphasize that, if the code work as you requested, pressing the up arrow of the answer did not kill anybody until now... :-) Are there cases when more then three columns are involved? If yes, until which maximum do you expect to have them? — FaneDuru, Dec 13 '19 at 17:58

Extract Unique Values From Multiple Columns With Macro

4 Answers4