使用宏从多列中提取唯一值

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

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