VBA 穷举/遍历找相同, 统计及标示

On_fire

gwjkkkkk 发表于 2022-11-16 20:55
请楼主参考 。。。

老师,
早上好, 请问您能帮忙做注释吗?
我想研究一下思路,
您的代码已经决解了大部分问题了…

liulang0808

Sub test()
    Dim brr()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets(1).UsedRange
    Application.ScreenUpdating = False
    For j = 1 To UBound(arr)
        Set d(j) = CreateObject("scripting.dictionary")
        For i = 1 To UBound(arr, 2)
            If Len(arr(j, i)) > 0 Then
                d(j)(arr(j, i)) = ""
            End If
        Next i
    Next j
    For j = 1 To UBound(arr)
        ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
        For i = 1 To UBound(arr, 2)
            brr(1, i) = arr(j, i)
        Next i
        r = 1
        For i = 1 To UBound(arr)
            If i <> j Then
                r = r + 1
                c = 1
                For k = 1 To UBound(arr, 2)
                    If Len(arr(i, k)) > 0 And d(j).exists(arr(i, k)) Then
                        c = c + 1
                        brr(r, c) = arr(i, k)
                    End If
                Next k
                brr(r, 1) = c - 1
            End If
        Next i
        Sheets(1).Copy after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = arr(j, 1)
        Sheets(Sheets.Count).[a1].Resize(UBound(brr), UBound(brr, 2)) = brr
    Next j
    Application.ScreenUpdating = True
End Sub

liulang0808

附件内容供参考。。。。

On_fire

liulang0808 发表于 2022-11-19 09:56
附件内容供参考。。。。

厉害!
版主, 请问如何解决在AA列往右输出同行的源数据?
差这一点, 就完美了…

liulang0808

On_fire 发表于 2022-11-19 10:07
厉害!
版主, 请问如何解决在AA列往右输出同行的源数据?
差这一点, 就完美了…

Sheets(1).Copy after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = arr(j, 1)
        Sheets(Sheets.Count).[a1].Resize(UBound(brr), UBound(brr, 2)) = brr

这个地方楼主可以根据需求调整

liulang0808

建议楼主以后发帖，结合附件内容在附件中模拟出具体结果，并解释说明具体步骤
特别是要避免模拟结果有出入

On_fire

liulang0808 发表于 2022-11-19 10:18
Sheets(1).Copy after:=Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = arr(j, 1)
        ...

版主,
请帮忙为代码做一些注释吗?
因为能力有限, 似懂非懂...

准提部林

AA-AG及AJ-AP都要COPY數據源, 只是順序不同???

AA-AG與第一行相同的還要標示顏色???
為何第二行相同的1及3沒標色?

源資料有上萬行, 每行建一工作表, 每工作表有兩倍以上的資料行???
這檔案弄下來有多大???
只刪表/建表//COPY資料就夠嗆了, 哪能求效率!!!

On_fire

liulang0808 发表于 2022-11-19 10:20
建议楼主以后发帖，结合附件内容在附件中模拟出具体结果，并解释说明具体步骤
特别是要避免模拟结果有出入

好的,
有时候自己也不是很清楚朋友的要求?
感谢您的帮助...

On_fire

准提部林 发表于 2022-11-19 10:32
AA-AG及AJ-AP都要COPY數據源, 只是順序不同???

AA-AG與第一行相同的還要標示顏色???

谢谢老师...

*

刚看到, 模拟结果还是有缺失, 抱歉…

*

行与行之间, 有相同的数据才保留在各自的分表中,

因为行与行之间, 不一定有相同值, 所以数据行也不一定很多,

有些分表可能是一行...

*

COPY是我的思路及想法, 写入数组再输出, 应会更快些…

版主的代码, 好像不是按我的思路写的…

*

文檔可能要十多兆(M)?