VBA 找重复及标示

On_fire

VBA 找重复及标示

*

Sheet1是源数据,

每一行是一组数据 ( 有空 ), 行列是变量

*

代码的逻辑如下,

1.     用Sheet1的A列字符, 顺序上到下, 分拆成多个表

2.    每个表的第一行是对应A列字符行( 每一行数据 )

3.    本行要顺序上到下, 左到右,与其他行做对比 ( 遍历单元格 ), 找重复值

4.    如对上(找到重复值), 就在B列输出去空的那一行数据,

5.    同时将所有重复值标黄底

*

源数据N多,

对速度有要求,  有难度,

恳请大神, 老师出手帮忙…谢谢!!

fzxba

测试.zip (23.07 KB, 下载次数: 15)

2024-3-8 17:20 上传

点击文件名下载附件

gwjkkkkk

fzxba 发表于 2024-3-8 17:20

不错，又学到了。。。

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, cr(), i&, j&, k&, r&, dic As Object
    Dim wks As Worksheet, iPosRow&, isFlag As Boolean
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    For Each wks In Worksheets
       If wks.Name <> ActiveSheet.Name Then wks.Delete
    Next
   
    ar = ActiveSheet.UsedRange.Value
    For i = 1 To UBound(ar)
        dic.RemoveAll
        For j = 1 To UBound(ar, 2)
            If Len(ar(i, j)) Then dic(ar(i, j)) = Empty
        Next j
        With Worksheets.Add(after:=Worksheets(Worksheets.Count))
            .Name = ar(i, 1)
            .[A1].Resize(, UBound(ar, 2)) = Application.Index(ar, i)
            iPosRow = 1
            For k = 1 To UBound(ar)
                If k <> i Then
                    Erase cr: r = 0: isFlag = False
                    For j = 1 To UBound(ar, 2)
                        If Len(ar(k, j)) Then
                             r = r + 1
                             ReDim Preserve cr(1 To 2, 1 To r)
                             cr(1, r) = ar(k, j)
                             If dic.Exists(cr(1, r)) Then isFlag = True: cr(2, r) = True
                        End If
                    Next j
                    If isFlag Then
                        iPosRow = iPosRow + 1
                        With .Cells(iPosRow, 2).Resize(, UBound(cr, 2))
                            .Value = cr
                            For j = 1 To UBound(cr, 2)
                                If cr(2, j) = True Then .Cells(1, j).Interior.Color = vbYellow
                            Next j
                        End With
                    End If
                End If
            Next k
        End With
    Next i

   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Beep
End Sub

gwjkkkkk

参与一下，写得啰嗦了。。。

yynrzwh

rebuilt2.zip (21.87 KB, 下载次数: 11)

2024-3-8 20:19 上传

点击文件名下载附件

On_fire

fzxba 发表于 2024-3-8 17:20

统一回复, 感谢各大神们的帮忙…