|
|
楼主 |
发表于 2024-8-28 11:08
|
显示全部楼层
Sub UniversalSplit()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim startTime As Double
startTime = Timer ' 记录开始时间
Dim fso As Object
Dim d As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set d = CreateObject("Scripting.Dictionary")
Dim path As String
path = ThisWorkbook.Path & "\" ' 获取当前工作簿路径
Dim ws As Workbook
Set ws = ThisWorkbook
Dim sh As Worksheet
Set sh = ws.Sheets("汇总表") ' 设置汇总表为目标工作表
On Error Resume Next
Dim arr As Variant
arr = sh.UsedRange ' 获取汇总表的所有数据
' 获取用户输入的部门列和子键列
Dim departmentCol As Long
Dim subKeyCol As Long
departmentCol = Application.InputBox("请输入部门列的列号（例如 A=1, B=2 等）：", Type:=1)
subKeyCol = Application.InputBox("请输入子键列的列号（例如 A=1, B=2 等）：", Type:=1)
' 获取列数
Dim totalCols As Long
totalCols = UBound(arr, 2)
' 创建一个数组来存储用户输入的新单元格地址
Dim newCellAddresses() As String
ReDim newCellAddresses(1 To totalCols)
' 遍历每一列，获取用户输入的新单元格地址
Dim colIndex As Long
For colIndex = 1 To totalCols
newCellAddresses(colIndex) = Application.InputBox("请输入要写入 '" & arr(1, colIndex) & "' 的单元格地址（例如 A1）：", Type:=2)
Next colIndex
' 遍历汇总表的数据
Dim i As Long
For i = 2 To UBound(arr, 1) ' 从第二行开始
Dim department As String
Dim subKey As Variant
Dim values() As Variant
department = CStr(arr(i, departmentCol)) ' 使用用户指定的部门列
subKey = arr(i, subKeyCol) ' 使用用户指定的子键列
' 如果字典中不存在该部门，则添加
If Not d.Exists(department) Then
Set d(department) = CreateObject("Scripting.Dictionary")
End If
' 如果该部门的字典中不存在子键，则添加
If Not d(department).Exists(subKey) Then
ReDim values(1 To totalCols - 2) ' 根据列数调整数组大小
For colIndex = 1 To totalCols
If colIndex <> departmentCol And colIndex <> subKeyCol Then
values(colIndex - 2) = arr(i, colIndex) ' 存储除部门列和子键列外的值
End If
Next colIndex
d(department)(subKey) = values
Else
' 如果子键已存在，则累加对应的值
values = d(department)(subKey)
For colIndex = 1 To totalCols
If colIndex <> departmentCol And colIndex <> subKeyCol Then
values(colIndex - 2) = values(colIndex - 2) + arr(i, colIndex) ' 累加非部门列和子键列的值
End If
Next colIndex
d(department)(subKey) = values
End If
Next i
' 遍历字典，创建新的工作簿
Dim k As Variant
For Each k In d.Keys
Application.SheetsInNewWorkbook = d(k).Count ' 设置新工作簿的工作表数量
Dim wb As Workbook
Set wb = Workbooks.Add
Dim m As Long
m = 0
Dim kk As Variant
For Each kk In d(k).Keys
m = m + 1
values = d(k)(kk)
ws.Sheets("拆分模板").Cells.Copy wb.Sheets(m).[A1] ' 复制模板
With wb.Sheets(m)
.Name = kk ' 设置工作表名为子键
' 遍历所有列，写入用户指定的新单元格地址
For colIndex = 1 To totalCols
If colIndex <> departmentCol And colIndex <> subKeyCol Then
.Range(newCellAddresses(colIndex)).Value = values(colIndex - 2) ' 写入累加值
End If
Next colIndex
.Range(newCellAddresses(departmentCol)).Value = k ' 在指定的单元格中写入部门名
.Range(newCellAddresses(subKeyCol)).Value = kk ' 在指定的单元格中写入子键
End With
Next kk
wb.SaveAs path & k & ".xlsx" ' 按部门名称保存工作簿
wb.Close False ' 关闭工作簿
Next k
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "拆分完毕，共用时：" & Format(Timer - startTime, "0.00") & "秒！"
End Sub
以上是AI修改后的代码，可以运行但是不方便，指定新位置时要记得模板表格，运行后第二列的数据全部为空，不知道是什么原因 |
|
楼主: ·遁去的一·
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-8-28 07:20
