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中带有sku的单元格d4中。它应该没有宏。

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

Answer 2

这将构建所有重复项和所有重复项的列表。然后它将使用函数Range.RemoveDuplicates删除SKU代码的重复项，并结合该范围内的URL。

显式选项

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脚本运行时”的引用。否则，您可以声明hUnq As Object ... 并且不要忘记在存在此代码的模块上添加Option Base。有必要使用构建初始代码的方式来工作。

编辑：按照您的建议，我修改了代码以接受最多六列。请试一试。但是它仅检查唯一的SKU Code并选择第一个匹配项。如果出现其他事件，即使它们在行上具有不同的字符串，也不会考虑。从这个角度来看，代码也可以适用于工作，但是现在我认为该轮到您进行一些测试了……

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

4 个答案: