利用VBA“字典”求两列数据的唯一解

二哥exe

各位大神：
       我想利用“字典”，将sheet"数据"中的“J＆O列”不重复项，提取到sheet“结果”中，求代码，详情参照附件

f8b1987

将J:O范围放到数组中，参照字典教程，循环一遍J列、O列数组放入字典就行了，

jy03342543

Option Explicit
Sub Test()
Dim D As Object
Dim Arr, Brr, Crr
Dim I As Integer
Set D = CreateObject("Scripting.Dictionary")
Worksheets("数据").Select
Arr = Range("J1:O" & Cells(Rows.Count, "J").End(3).Row)
          For I = 2 To UBound(Arr)
                 D(Arr(I, 1) & "-" & Arr(I, 6)) = ""
          Next I
    ReDim Crr(1 To D.Count)
    Brr = D.keys
    For I = 1 To D.Count
          Crr(I) = Split(Brr(I - 1), "-")
    Next I
Worksheets("结果").Select
Range("A2").Resize(6, 2) = Application.Transpose(Application.Transpose(Crr))
End Sub

jy03342543

代码审核中先传个压缩包给你

gyx9233

A2=OFFSET(数据!$J$1,SMALL(IF(MATCH(数据!$J$2:$J$32&数据!$O$2:$O$32,数据!$J$2:$J$32&数据!$O$2:$O$32,0)=ROW($A$1:$A$31),ROW($A$1:$A$31),2^8),ROW(A1)),0)
B2=OFFSET(数据!$O$1,SMALL(IF(MATCH(数据!$J$2:$J$32&数据!$O$2:$O$32,数据!$J$2:$J$32&数据!$O$2:$O$32,0)=ROW($A$1:$A$31),ROW($A$1:$A$31),2^8),ROW(B1)),0)

数组公式

二哥exe

gyx9233 发表于 2020-11-18 14:53
A2=OFFSET(数据!$J$1,SMALL(IF(MATCH(数据!$J$2:$J$32&数据!$O$2:$O$32,数据!$J$2:$J$32&数据!$O$2:$O$32,0 ...

很感谢您的回复，只是不想用公式来解决

二哥exe

f8b1987 发表于 2020-11-18 14:37
将J:O范围放到数组中，参照字典教程，循环一遍J列、O列数组放入字典就行了，

抱歉，我是字典小白，所以你说的我不理解

二哥exe

jy03342543 发表于 2020-11-18 14:45
代码审核中先传个压缩包给你

厉害，这就是我想要的，非常感谢

levey

Sub onlyone()
Set d = CreateObject("scripting.dictionary")
lastrow = Sheets("数据").Range("J65536").End(xlUp).Row
arr = Sheets("数据").Range("A1:AN" & lastrow)
With Sheets("数据")
    For i = 1 To UBound(arr)
        d(arr(i, 10) & vbTab & arr(i, 15)) = Array(arr(i, 10), arr(i, 15))
    Next
End With
Sheets("结果").Range("a1").Resize(d.Count, 2) = Application.Transpose(Application.Transpose(d.items))
End Sub

levey

Sub onlyone()
Set d = CreateObject("scripting.dictionary")
lastrow = Sheets("数据").Range("J65536").End(xlUp).Row
arr = Sheets("数据").Range("A1:AN" & lastrow)
With Sheets("数据")
    For i = 1 To UBound(arr)
        d(arr(i, 10) & vbTab & arr(i, 15)) = Array(arr(i, 10), arr(i, 15))
    Next
End With
Sheets("结果").Range("a1").Resize(d.Count, 2) = Application.Transpose(Application.Transpose(d.items))
End Sub