多簿多表合并，结果不对。请各位帮助修改一下。

jjmysjg

筛选出文件夹内不重复姓名，对应数据按字段填入--字段B2C2,数据B3C3开始。

数据源发生变化，照抄老师代码，结果出错。
麻烦各位老师帮忙修改一下。
谢谢各位！

jjmysjg

谢谢各位老师

jjmysjg

这个代码集工作簿名、工作表名、字段名于一表，经典实用。希望在原码修改

鄂龙蒙

20250412.rar (129.9 KB, 下载次数: 19)

2025-4-12 15:32 上传

点击文件名下载附件

jjmysjg

鄂龙蒙 发表于 2025-4-12 15:32

谢谢老师，就是这个结果

yanglinzi

重新写个代码。。

ykcbf1100

我不喜欢改别人的代码，自己写一个吧，权当练习了。

ykcbf1100

1. Sub ykcbf()   '//2025.4.12  多文件多表排重汇总
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     p = ThisWorkbook.Path & ""
   
7.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
8.     ReDim brr(1 To 10000, 1 To 100)
   
9.     m = 3: n = 1
   
10.     brr(1, 1) = "工作簿名"
    
11.     brr(2, 1) = "工作表名"
    
12.     brr(3, 1) = "姓名"
    
13.     Dim tm: tm = Timer
    
14.     On Error Resume Next
    
15.     For Each f In fso.GetFolder(p).Files
    
16.         If LCase$(f.Name) Like "*.xls*" Then
    
17.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
18.                 fn = fso.GetBaseName(f)
    
19.                 Set wb = Workbooks.Open(f, 0)
    
20.                 For Each sht In wb.Sheets
    
21.                     If IsArray(sht.UsedRange) Then
    
22.                         arr = sht.UsedRange
    
23.                         n = n + 1
    
24.                         brr(1, n) = fso.GetBaseName(f)
    
25.                         brr(2, n) = sht.Name
    
26.                         For i = 3 To UBound(arr)
    
27.                             S = arr(i, 2)
    
28.                             If S <> Empty Then
    
29.                                 If Not d.exists(S) Then
    
30.                                     m = m + 1
    
31.                                     d(S) = m
    
32.                                     brr(m, 1) = S
    
33.                                 End If
    
34.                                 r = d(arr(i, 2))
    
35.                                 brr(r, n) = brr(r, n) + arr(i, 3)
    
36.                             End If
    
37.                         Next
    
38.                         brr(3, n) = arr(2, 3)
    
39.                     End If
    
40.                 Next
    
41.                 wb.Close 0
    
42.             End If
    
43.         End If
    
44.     Next
    
45.     n = n + 1: m = m + 1
    
46.     brr(1, n) = "行向合计": brr(m, 1) = "列向合计"
    
47.     For i = 4 To m - 1
    
48.         brr(i, n) = Application.Sum(Application.Index(brr, i))
    
49.     Next
    
50.     For j = 2 To n
    
51.         brr(m, j) = Application.Sum(Application.Index(brr, 0, j))
    
52.     Next
    
53.     With sh
    
54.         .UsedRange.Clear
    
55.         .Cells.Interior.ColorIndex = 0
    
56.         .[a1].Resize(3, n).Interior.Color = 49407
    
57.         .[a4].Resize(m - 3, 1).Interior.Color = 5296274
    
58.         .UsedRange.Offset(1, 1).NumberFormatLocal = "0"
    
59.         With .[a1].Resize(m, n)
    
60.             .Value = brr
    
61.             .Borders.LineStyle = 1
    
62.             .HorizontalAlignment = xlCenter
    
63.             .VerticalAlignment = xlCenter
    
64.             With .Font
    
65.                 .Name = "微软雅黑"
    
66.                 .Size = 11
    
67.             End With
    
68.         End With
    
69.         .Cells(1, n).Resize(3).Merge
    
70.     End With
    
71.     Application.ScreenUpdating = True
    
72.     MsgBox "共用时：" & Format(Timer - tm, "0.000") & "秒！"
    
73. End Sub
    

复制代码

jjmysjg

yanglinzi 发表于 2025-4-12 17:14
重新写个代码。。

谢谢大师！下载

jjmysjg

ykcbf1100 发表于 2025-4-12 17:35
我不喜欢改别人的代码，自己写一个吧，权当练习了。

谢谢大侠，汇总