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

Question

我在 A 中有一個代碼列表，在 B 和 C 中有圖像鏈接。

我想要做的是刪除重復項並將唯一鏈接排列在一個列中，並給它們一個系列名稱，在圖像鏈接 1 之前不增加 code_1，在鏈接 2 之前增加 code_2，如圖所示。

我正在嘗試使用此代碼刪除重復項，但對如何將名稱放在鏈接之前一無所知。

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

此自定義 VBA 函數將創建獲取 SKU 代碼的所需結果。 我將其分解以展示如何獲得每個位置。

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

作為后續，您還可以在沒有 VBA 的情況下創建 sku。 如果您將此公式放在單元格c4 ，並在d4使用 sku。 它應該沒有宏。

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

Answer 2

這將構建所有重復項和所有項的列表。 然后它會使用函數Range.RemoveDuplicates結合范圍內的 URL 刪除 SKU 代碼的重復項。

選項顯式

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

這可能會幫助您：

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

請試試這個：我修改了你的代碼。 字典就像一個避免重復值的工具一樣使用（因為它存在......）。 一切都在內存中工作，應該非常快：

    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

'必須添加對“Microsoft Scripting Runtime”的引用。 否則，您可以將hUnq As Object聲明hUnq As Object ... 並且不要忘記在此代碼所在的模塊的tot 上設置Option Base 。 有必要使用您構建初始代碼的方式。

編輯：我按照您的建議修改了代碼以接受最多六列。 請試一試。 但它只檢查唯一的SKU Code並選擇第一次出現。 如果出現其他出現，即使它們在其行上有不同的字符串，也不會被考慮。 從這個角度來看，代碼也可以適應工作，但現在我想輪到你做一些測試了......