重复信息汇总

app240913

有很多个文件表，每个表有很多信息，现在需要对所有文件表第10行重复备注信息进行汇总，按格式汇总到重复信息的文件表中（同一张表可能存在重复，不同表也可能存在重复）

3190496160

Sub 汇总()
Dim ar As Variant
Dim br()
Dim sh As Worksheet
ReDim br(1 To 10000, 1 To 4)
For Each sh In Sheets
    If sh.Name <> "重复信息" Then
        y = sh.Cells(10, Columns.Count).End(xlToLeft).Column
        ar = sh.Range(sh.Cells(9, 1), sh.Cells(10, y))
        For j = 2 To UBound(ar, 2)
            If ar(2, j) <> "" Then
                n = n + 1
                br(n, 1) = ar(1, j)
                br(n, 2) = ar(2, j)
                br(n, 3) = sh.Name
                br(n, 4) = j
            End If
        Next j
    End If
Next sh
With Sheets("重复信息")
    .[a1].CurrentRegion.Offset(1) = Empty
    .[a2].Resize(n, UBound(br, 2)) = br
End With
MsgBox "ok!"
End Sub

3190496160

重复信息汇总918.rar (19.13 KB, 下载次数: 5)

2024-9-19 07:23 上传

点击文件名下载附件

ykcbf1100

附件供参考

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.9.19
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set sh = ThisWorkbook.Sheets("重复信息")
   
4.     For Each sht In Sheets
   
5.         If sht.Name <> sh.Name Then
   
6.             With sht
   
7.                 c = .Cells(9, "XFD").End(1).Column
   
8.                 arr = .[a9].Resize(2, c)
   
9.                 For j = 2 To UBound(arr, 2)
   
10.                     s = arr(2, j)
    
11.                     d(s) = d(s) + 1
    
12.                 Next
    
13.             End With
    
14.         End If
    
15.     Next
    
16.     ReDim brr(1 To 10000, 1 To 4)
    
17.     For Each sht In Sheets
    
18.         If sht.Name <> sh.Name Then
    
19.             With sht
    
20.                 c = .Cells(9, "XFD").End(1).Column
    
21.                 arr = .[a9].Resize(2, c)
    
22.                 For j = 2 To UBound(arr, 2)
    
23.                     s = arr(2, j)
    
24.                     If d(s) > 1 Then
    
25.                         m = m + 1
    
26.                         brr(m, 1) = arr(1, j)
    
27.                         brr(m, 2) = arr(2, j)
    
28.                         brr(m, 3) = .Name
    
29.                         brr(m, 4) = j
    
30.                     End If
    
31.                 Next
    
32.             End With
    
33.         End If
    
34.     Next
    
35.     With sh
    
36.         .UsedRange.Offset(1).ClearContents
    
37.         .[a2].Resize(m, 4) = brr
    
38.     End With
    
39.     Set d = Nothing
    
40.     MsgBox "OK！"
    
41. End Sub
    

复制代码

cyq4896

学习一下...

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")
                d(arr(2, j))(j) = Array(arr(1, j), sh.Name)
            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) = kk
            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.     arr = sht.Range("a9").CurrentRegion.Value
   
8.     For c = 2 To UBound(arr, 2)
   
9.         
   
10.         s = arr(2, c)
    
11.         If Not dic.exists(s) Then
    
12.             dic(s) = Array(arr(1, c), sht.Name, c)
    
13.         Else
    
14.             m = m + 1
    
15.             k = dic(s)
    
16.             brr(m, 1) = k(0): brr(m, 2) = s
    
17.             brr(m, 3) = k(1): brr(m, 4) = k(2)
    
18.             m = m + 1
    
19.             brr(m, 1) = arr(1, c): brr(m, 2) = s
    
20.             brr(m, 3) = sht.Name: brr(m, 4) = c
    
21.         End If
    
22.     Next c
    
23. End If
    
24. Next sht
    
25. With Sheet3
    
26.     .Cells.Clear
    
27.     .Range("a1").Resize(1, 4) = crr
    
28.     .Range("a2").Resize(m, 4) = brr
    
29.     .ListObjects.Add xlSrcRange, [a1].CurrentRegion, , xlYes
    
30. End With
    
31. End Sub
    

复制代码

Qs18

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