如何根据汇总表中的dw列按照单位名称拆分成多个工作簿

反璞归真

求助大师帮忙写代码：如何根据汇总表中的dw列按照单位名称拆分成多个工作簿，有很多数据这只是截取了一部分数据，按文件夹中的形式拆分，求大师们帮帮忙，十分感谢！

shiruiqiang

============

ykcbf1100

2级字典，附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.5.25  总表拆分为多工作簿
   
2.     Dim wb, arr, sh
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     Set sh = ThisWorkbook.Sheets("汇总表")
   
8.     arr = sh.UsedRange
   
9.     bt = 1        '//标题行数
   
10.     col = 6       '//拆分列号
    
11.     For i = bt + 1 To UBound(arr)
    
12.         s = arr(i, col)
    
13.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
14.         d(s)(i) = Application.Index(arr, i)
    
15.     Next
    
16.     For Each k In d.keys
    
17.         sh.Copy
    
18.         Set wb = ActiveWorkbook
    
19.         m = d(k).Count
    
20.         With wb.Sheets(1)
    
21.             .Name = k
    
22.             .DrawingObjects.Delete
    
23.             .UsedRange.Offset(bt + m).Clear
    
24.             .Columns(4).NumberFormatLocal = "@"
    
25.             .Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k).Items, 1)
    
26.         End With
    
27.         wb.SaveAs p & k
    
28.         wb.Close 1
    
29.     Next
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    
33. 
    

复制代码

反璞归真

谢谢大师们帮忙指导

LIUZHU

算是一个经典的问题了，解决方案VBA和JSA都挺多的

LIUZHU

我做的效果

LIUZHU

JSA代码，较VBA精简点

1. function 工作簿拆分(){
   
2.         let arr=Range("a1").CurrentRegion.Value2;
   
3.         let obj=arr.slice(1).reduce((obj,x)=>{
   
4.                 obj[x[5]]=obj[x[5]] || [arr[0]];
   
5.                 return(obj[x[5]].push(x),obj);
   
6.         },{});
   
7.         for (let key in obj){
   
8.                 let temp=obj[key];
   
9.                 Workbooks.Add().SaveAs(`${ThisWorkbook.Path}\\${key}.xlsx`);;
   
10.                 Range("a1").Resize(temp.length,temp[0].length).Value2=temp;
    
11.                 ActiveWorkbook.Close(true);
    
12.         }
    
13.         alert("拆分完毕。");
    
14. }

复制代码

LIUZHU

附件，WPS测试，运行JS宏