重复信息汇总

Qs18

试试.............

quqiyuan

前面关键字没想好，造成有遗漏，现在用了表名+列号作为关键字，没有错了

quqiyuan

代码如下。。。
Sub test()
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("重复信息")
    Set d = CreateObject("scripting.dictionary")
    For Each sh In wb.Sheets
        If sht.Name <> sh.Name Then
            arr = sh.[a10].CurrentRegion
            For j = 2 To UBound(arr, 2)
                If Not d.exists(arr(2, j)) Then Set d(arr(2, j)) = CreateObject("scripting.dictionary")
                s = sh.Name & "|" & j
                d(arr(2, j))(s) = Array(arr(1, j), sh.Name, j)
            Next
        End If
    Next
    ReDim brr(1 To 10000, 1 To 4)
    For Each k In d.keys
        Key = d(k).keys
        If UBound(Key) > 0 Then
            For Each kk In Key
                n = n + 1
                brr(n, 1) = d(k)(kk)(0)
                brr(n, 3) = d(k)(kk)(1)
                brr(n, 2) = k
                brr(n, 4) = d(k)(kk)(2)
            Next
        End If
    Next
    With sht
        .UsedRange.Clear
        .[a1:d1] = [{"日期","备注","文件表名称","列号"}]
        .[a2].Resize(n, 4) = brr
        .UsedRange.Columns.AutoFit
        .UsedRange.HorizontalAlignment = xlCenter
        .UsedRange.Borders.LineStyle = 1
    End With
    Set d = Nothing
    Beep
End Sub

Qs18

1. Sub qs() '2024\09\19
   
2. Dim arr, i, dic, sht As Worksheet
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. ReDim brr(1 To 50000, 1 To 4): crr = [{"日期","备注","文件名称","列号"}]
   
5. For Each sht In Sheets
   
6. If sht.Name <> "重复信息" Then
   
7.     cl = sht.Cells(9, Columns.Count).End(xlToLeft).Column
   
8.     arr = sht.Range(sht.Cells(9, 1), sht.Cells(10, cl))
   
9.     For c = 2 To UBound(arr, 2)
   
10.         s = arr(2, c)
    
11.         If Not dic.exists(s) Then
    
12.             dic(s) = arr(1, c) & "'" & arr(2, c) & "'" & sht.Name & "'" & c
    
13.         Else
    
14.             dic(s) = dic(s) & "|" & arr(1, c) & "'" & arr(2, c) & "'" & sht.Name & "'" & c
    
15.         End If
    
16.     Next c
    
17. End If
    
18. Next sht
    
19. For Each k In dic.keys
    
20.     kk = Split(dic(k), "|")
    
21.     If UBound(kk) > 0 Then
    
22.         For i = 0 To UBound(kk)
    
23.             m = m + 1
    
24.             kkk = Split(kk(i), "'")
    
25.             For j = 0 To UBound(kkk)
    
26.                 brr(m, j + 1) = kkk(j)
    
27.             Next
    
28.         Next
    
29.    
    
30.     End If
    
31. Next
    
32. With Sheet3
    
33.     .Cells.Clear
    
34.     .Range("a1").Resize(1, 4) = crr
    
35.     .Range("a2").Resize(m, 4) = brr
    
36.     .ListObjects.Add xlSrcRange, .[a1].CurrentRegion, , xlYes
    
37. End With
    
38. End Sub

复制代码

Qs18

修改了一下..........

Qs18

修改了一下试试...........