如何按部门、成本支出项目拆分工作簿为多个文件

天山神鹰

原表，待拆分

上面是原工作簿的内容，A、B两列是序号和费用项目，其中A1单元格是手工输入的月份，供其他单元格根据预算和支出计算节超额。
再往右每三列（如BCD、FGH等）是一个部门的数据。

拆分后的表

根据管理需要，每月要把各部门的费用项目及预算、支出、节超发给各部门，格式如上图所示。
需要根据每个部门名字生成对应的Excel文件，文件名为“部门名称+月份”，月份使用A1单元格的数据。
我试了好几次都没有成功，恳请高手们相助，多谢啦！！！！
测试.rar (16.09 KB, 下载次数: 8)

2024-4-2 16:01 上传

点击文件名下载附件

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.2
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set sh = Sheets("明细")
   
7.     arr = sh.UsedRange
   
8.     yf = sh.[a1]
   
9.     Set Rng = sh.Columns(UBound(arr, 2) + 1)
   
10.     For j = 3 To UBound(arr, 2)
    
11.         S = arr(2, j)
    
12.         If S <> Empty Then d(S) = j
    
13.     Next
    
14.     For Each k In d.keys
    
15.         sh.Copy
    
16.         Set wb = ActiveWorkbook
    
17.         With wb.Sheets(1)
    
18.             t = d(k)
    
19.             .Name = k
    
20.             .DrawingObjects.Delete
    
21.             For j = UBound(arr, 2) To 3 Step -1
    
22.                 If j < t Or j > t + 2 Then
    
23.                     .Columns(j).Delete
    
24.                 End If
    
25.             Next
    
26.         End With
    
27.         wb.SaveAs p & k & "-" & yf & "月"
    
28.         wb.Close
    
29.     Next
    
30.     Set d = Nothing
    
31.     Application.ScreenUpdating = True
    
32.     MsgBox "OK！"
    
33. End Sub
    

复制代码

LIUZHU

JSA代码参与下

1. function 工作簿拆分(){
   
2.         let bt=Range("a1").CurrentRegion.Value2[0];
   
3.         let obj=bt.reduce((dic,x,i)=>(i>1 && x!=null?dic[x]=Cells(1,i+1).MergeArea.Address():null,dic),{});
   
4.         let arr=Object.values(obj),month=bt[0],path=ThisWorkbook.Path;
   
5.         for (let key in obj){
   
6.                 let temp=[...arr];
   
7.                 ActiveSheet.Copy();
   
8.                 Range(temp.splice(arr.indexOf(obj[key]),1).join(",")).EntireColumn.Delete();
   
9.                 ActiveWorkbook.SaveAs(`${path}\\${key}-${month}月.xlsx`,51);
   
10.                 ActiveWorkbook.Close(false);
    
11.         }
    
12. }

复制代码

LIUZHU

WPS打开运行测试

LIUZHU

确认下，是按照部门拆分，还是按照部门下的子部门拆分？比如是按照销售部拆分，还是按照销售部门下面的东亚公司拆分？

天山神鹰

LIUZHU 发表于 2024-4-2 21:26
确认下，是按照部门拆分，还是按照部门下的子部门拆分？比如是按照销售部拆分，还是按照销售部门下面的东亚 ...

按照子部门拆分。
谢谢您的关注和回复！！

天山神鹰

ykcbf1100 发表于 2024-4-2 20:33
参与一下。。。

您的代码很给力，略加修改即可完美运行，非常感谢您！！！

jjmysjg

ykcbf1100 发表于 2024-4-2 20:31
附件供参考。。。

复杂的事情在高手手里变简单