Extract Unique Values From Multiple Columns With Macro - excel

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

Answer 1

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),"?",""),"-","_")

Answer 2

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

Answer 3

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

Answer 4

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...