VBA 每行右侧数据取唯一值

On_fire

VBA 每行右侧数据取唯一值

*

Sheet1是源数据,

行数及列数都是变量

每一行有空格

*

代码的逻辑如下,

1.      同行K列开始往右, 只取唯一值 ( Sheet1(2), 去重复, 如标黄 )

2.      同行K列开始往右, 同行去空格

3.      模拟结果在Sheet1(3)

*

恳请大神, 老师帮忙...谢谢!

gwjkkkkk

1.Sheet1(2)是模拟结果？

gwjkkkkk

Sheet1(2)是模拟结果？？？

On_fire

gwjkkkkk 发表于 2024-1-30 18:58
Sheet1(2)是模拟结果？？？

老师好,
Sheet1(2)是模拟要去重复的, 如标黄的单元格
最后的模拟结果在Sheet1(3)

cjc209

function test(){
        var arr=maxArray_Z("Sheet1!k1:z1");
        var arr1=arr.map((r,i,brr)=>{
                return brr[i].filter(x=>x!=null).distinct_Z();
        });
        arr1=zip_Z([maxArray_Z("Sheet1!a1:j1"),arr1]).pad_Z();
        arr1.toRange_Z("Sheet3!a10")
}

cjc209

结果图

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, j&, iC&, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    With Sheets(1).UsedRange
        With Intersect(.Offset(), .Offset(, 10))
            ar = .Value
            ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
            .Cells.Clear
            For i = 1 To UBound(ar)
                dic.RemoveAll: iC = 0
                For j = 1 To UBound(ar, 2)
                    If Len(ar(i, j)) Then dic(ar(i, j)) = Empty
                Next j
                If dic.Count > 0 Then
                    For j = 0 To dic.Count - 1
                        iC = iC + 1
                        br(i, iC) = dic.keys()(j)
                    Next j
                End If
            Next i
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Value = br
        End With
    End With
   
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考。。。

On_fire

gwjkkkkk 发表于 2024-1-30 19:22
请参考。。。

感谢老师,
用offset太聪明, 真想不到可这样用...