Fatal编程技术网
  • excel/
  • Excel 使用宏从多个列中提取唯一值

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

excel vba

Excel 使用宏从多个列中提取唯一值,excel,vba,Excel,Vba,我在a中有一个代码列表，在B和C中有图像链接 我想做的是删除重复项并将唯一链接安排在一列中，并为它们提供一个序列名，在图像链接1之前不增加代码_1，在链接2之前增加代码_2，如图所示 我试图用这段代码来删除重复的内容，但对如何将名称放在链接之前一无所知 Sub tgr() Dim wb As Workbook Dim wsDest As Worksheet Dim rData As Range Dim rArea As Range Dim aData

我在a中有一个代码列表，在B和C中有图像链接

我想做的是删除重复项并将唯一链接安排在一列中，并为它们提供一个序列名，在图像链接1之前不增加代码_1，在链接2之前增加代码_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
此自定义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
。它应该没有宏

=代用词（左代用词（右代用词（d4，“/”，REPT（“？”，999）），999），“？”，“.jpg”，REPT（“？”，999）），999），“？”，“-”，“”）

这将构建一个包含所有重复项和所有重复项的列表。然后，它将使用函数
Range.removedupplicates
删除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
这可能会帮助您：

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
请试试这个：我修改了你的代码。字典的使用就像一个避免重复值的工具（由于它的存在…）。一切都在内存中运行，速度应该非常快：

    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

选项库1
分包商
将wb作为工作簿，rData作为范围，wsDest作为工作表，rArea作为范围
Dim aData作为变量，aDataSorted（）作为字符串
Dim i和Scripting一样长，hUnq和Scripting一样长。Dictionary，nr列和Scripting一样长
出错时继续下一步
Set rData=Application.InputBox（“选择将提取唯一名称的名称范围：”，“数据选择”，选择.地址，类型：=8）
错误转到0
如果rData为空，则退出“按取消”
'Debug.Print rData.Columns.Count:停止
如果rData.Columns.Count>6，则MsgBox“超过6列…”&vbCrLf&_
“请仅选择六列，然后再次运行该过程”，vbInformation_
“列太多”：退出Sub
nrColumns=rData.Columns.Count
Set hUnq=CreateObject（“Scripting.Dictionary”）
对于rData.区域中的每个稀有物种
如果rArea.Cells.Count=1，则
雷迪姆数据（1对1，1对1）
aData（1，1）=稀有值
其他的
aData=稀有值
如果结束
ReDim aDataSorted（第1列）
暗k一样长
k=1
对于i=1到UBound（aData，1）
如果不存在hUnq（aData（i，1））和Len（Trim（aData（i，1）））>0，那么
aDataSorted（1，k）=aData（i，1）：aDataSorted（2，k）=aData（i，2）：aDataSorted（3，k）=aData（i，3）
选择Case列
案例4
如果aData（i，4）“，那么aDataSorted（4，k）=aData（i，4）
案例5
如果aData（i，4）“，那么aDataSorted（4，k）=aData（i，4）
如果aData（i，5）”，那么aDataSorted（5，k）=aData（i，5）
案例6
如果aData（i，4）“，那么aDataSorted（4，k）=aData（i，4）
如果aData（i，5）”，那么aDataSorted（5，k）=aData（i，5）
如果aData（i，6）”，那么aDataSorted（6，k）=aData（i，6）
案例>6
MsgBox“选择的列太多！”：退出子菜单
结束选择
k=k+1
雷迪姆保留自适应排序（NRK列）
hUnq（Trim（aData（i，1））=Trim（aData（i，1））
如果结束
接下来我
下一个稀有物种
'处理新阵列，以便转换所需内容：
将finalCol（）设置为字符串
k=k-1:Z=1
雷迪姆金融（2，Z）
暗指数和长指数一样
所有行的长度相同
对于i=1到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保留最终目标（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保留最终目标（2，Z）
如果nR列<4，则转到EndLoop
如果aDataSorted（4，i）“，则finalCol（1，Z）=aDataSorted（1，i）&“u”&lngIndex：_
lngIndex=lngIndex+1:finalCol（2，Z）=aDataSorted（4，i）：totalRows=totalRows+1:_
Z=Z+1:ReDim保留最终目标（2，Z）
如果nR列数小于5，则转到EndLoop
如果aDataSorted（5，i）“，则finalCol（1，Z）=aDataSorted（1，i）&“u”&lngIndex：_
lngIndex=lngIndex+1:finalCol（2，Z）=aDataSorted（5，i）：totalRows=totalRows+1:_
Z=Z+1:ReDim保留最终目标（2，Z）
如果nR列数小于6，则转到EndLoop
如果aDataSorted（6，i）“，则finalCol（1，Z）=aDataSorted（1，i）&“u”&lngIndex：_
lngIndex=lngIndex+1:finalCol（2，Z）=aDataSorted（6，i）：totalRows=totalRows+1:_
Z=Z+1:ReDim保留最终目标（2，Z）
结束循环：
接下来我
设置wb=rData.Parent.Parent
设置wsDest=wb.Sheets.Add（后面：=wb.Sheets（wb.Sheets.Count））
wsDest.Range（“A1:B”和totalRows）=应用程序转置（finalCol）
端接头
'必须添加对“Microsoft脚本运行时”的引用。否则，您可以将hUnq声明为对象。。。 并且不要忘记在该代码所在模块的tot上设置
选项库
。有必要使用构建初始代码的方式

编辑：我根据您的建议修改了代码，最多可以接受六列。恳求