【求助】如何合并多个工作簿到一个工作表并带子表格名字

cjc209

function test(){
        var arr=[...Sheets].flatMap(sht=>{
                if(sht.Name!="汇总"){
             return  sht.Range("a1").CurrentRegion.Value2.slice(1).map((x,i)=>[sht.Name,...x]);
        }
     })
    arr=arr.filter(x=>x!=null);
    Sheets("汇总").Range("a2").Resize(arr.length,arr[0].length).Value2=arr;
}

闻启学

哄哄1314 发表于 2024-2-8 16:41
是在哪个地方呢，没找到

cjc209

闻启学 发表于 2024-2-8 16:58

那是付费的

哄哄1314

cjc209 发表于 2024-2-8 17:07
那是付费的

嗯，上面有老师帮忙写了VBA，可以用，很方便，谢谢

ykcbf1100

汇总表自动生成。

ykcbf1100

参与一下。。。

1. Sub ykcbf2()   '//2024.2.8
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set Sh = ThisWorkbook.Sheets("汇总")
   
6.     ReDim brr(1 To 10000, 1 To 100)
   
7.     m = 1: n = 3
   
8.     For Each Sht In Sheets
   
9.         If Sht.Name <> Sh.Name Then
   
10.             With Sht
    
11.                 r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
12.                 arr = .[a1].Resize(r, 4)
    
13.                 fn = .Name
    
14.             End With
    
15.             For i = 2 To UBound(arr)
    
16.                 s = arr(i, 1)
    
17.                 If Not d.Exists(s) Then
    
18.                     m = m + 1
    
19.                     d(s) = m
    
20.                     brr(m, 1) = fn
    
21.                     brr(m, 2) = s
    
22.                     brr(m, 3) = arr(i, 2)
    
23.                 End If
    
24.                 s = arr(i, 3)
    
25.                 If Not d.Exists(s) Then
    
26.                     n = n + 1
    
27.                     d(s) = n
    
28.                     brr(1, n) = s
    
29.                 End If
    
30.                 r = d(arr(i, 1)): c = d(arr(i, 3))
    
31.                 brr(r, c) = brr(r, c) + arr(i, 4)
    
32.             Next
    
33.         End If
    
34.     Next
    
35.     With Sh
    
36.         .Cells.Clear
    
37.         With .[a1].Resize(m, n)
    
38.             .Value = brr
    
39.             .Borders.LineStyle = 1
    
40.             .HorizontalAlignment = xlCenter
    
41.             .VerticalAlignment = xlCenter
    
42.         End With
    
43.         .[a1:c1] = Array("表名", "姓名", "性别")
    
44.     End With
    
45.     Set d = Nothing
    
46.     Application.ScreenUpdating = True
    
47.     MsgBox "OK！"
    
48. End Sub
    

复制代码

ykcbf1100

理解错题意，想复杂了，原来是简单合并。

代码重写了，附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf2()   '//2024.2.9
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set Sh = ThisWorkbook.Sheets("汇总")
   
6.     ReDim brr(1 To 10000, 1 To 100)
   
7.     m = 1
   
8.     For Each Sht In Sheets
   
9.         If Sht.Name <> Sh.Name Then
   
10.             With Sht
    
11.                 r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
12.                 arr = .[a1].Resize(r, 4)
    
13.                 fn = .Name
    
14.             End With
    
15.             For i = 2 To UBound(arr)
    
16.                 m = m + 1
    
17.                 brr(m, 1) = fn
    
18.                 For j = 1 To UBound(arr, 2)
    
19.                     brr(m, j + 1) = arr(i, j)
    
20.                 Next
    
21.             Next
    
22.         End If
    
23.     Next
    
24.     With Sh
    
25.         .Cells.Clear
    
26.         With .[a1].Resize(m, 5)
    
27.             .Value = brr
    
28.             .Borders.LineStyle = 1
    
29.             .HorizontalAlignment = xlCenter
    
30.             .VerticalAlignment = xlCenter
    
31.         End With
    
32.         .[a1:e1] = Array("班级", "姓名", "性别", "科目", "总分")
    
33.     End With
    
34.     Set d = Nothing
    
35.     Application.ScreenUpdating = True
    
36.     MsgBox "OK！"
    
37. End Sub
    

复制代码

x-xx-xx