工作簿按明细sheet的固定字段进行拆分，如何自动化实现

sunyao0819 · 发表于 2023-10-10 17:03

工作簿有三类sheet组成：几个明细sheet、几个汇总sheet（根据明细sheet的公式计算）、参照sheet，先需要按照明细sheet中的一级部门、二级部门或者人员姓名拆分工作簿，拆分后的工作簿结构与拆分前一致，只是几个明细sheet中的部门或者人员姓名字段里只剩下拆分后的单一内容，这个拆分是否有自动化实现的方法？

3190496160 · 发表于 2023-10-11 08:43

方法肯定有，或者上传你的附件具体描述你的需求，或者到我的主题里面去找找，几个拆分工具一定有一个适合你的

沈默00 · 发表于 2023-10-11 08:56

上个附件先，估计得VBA了，

sunyao0819 · 发表于 2023-10-11 15:34

本帖最后由 sunyao0819 于 2023-10-11 17:06 编辑

已上传附件。
1、拆分字段：Team
2、拆分sheet：Summary、Contract、Revenue、回款
3、要求：按Team字段拆分成N个工作簿，拆分后的各工作簿结构保持不变

3190496160 · 发表于 2023-10-12 10:45

需要拆分的三个工作表的结构不一致，拆分字段所在列不一致，就比较麻烦，先留个记号呗

沈默00 · 发表于 2023-10-12 12:43

3190496160 发表于 2023-10-12 10:45
需要拆分的三个工作表的结构不一致，拆分字段所在列不一致，就比较麻烦，先留个记号呗

表格确实乱，不在一列倒是可以用match取值，第一个表格还不在同一行，

沈默00 · 发表于 2023-10-12 13:04

LZ这要求有点问题，三个分表的格式不一样，数据没办法整合呀，写了一半写不下去了

我都没看太明白，表格结构不变，又以哪个为准？你自己模拟下效果看看，

3190496160 · 发表于 2023-10-12 15:14

沈默00 发表于 2023-10-12 13:04
LZ这要求有点问题，三个分表的格式不一样，数据没办法整合呀，写了一半写不下去了
我都没看太明白，表 ...

楼主应该是要求一薄多表，拆分为多薄多表吧？

3190496160 · 发表于 2023-10-12 15:17

Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
For Each sh In Sheets(Array("Summary", "Contract", "Revnue"))
If sh.Name = "Summary" Then
      ks = 4
      js = 17
      lh = 1
ElseIf sh.Name = "Contract" Then
      ks = 3
      js = 9
      lh = 6
ElseIf sh.Name = "Revnue" Then
      ks = 3
      js = 10
      lh = 8
End If
r = sh.Cells(sh.Rows.Count, lh).End(xlUp).Row
ar = sh.Range(sh.Cells(1, 1), sh.Cells(r, js))
For i = ks To UBound(ar)
      If Trim(ar(i, lh)) <> "" Then
         d(Trim(ar(i, lh))) = ""
      End If
Next i
Next sh
For Each k In d.keys
m = 0
For Each sh In Sheets(Array("Summary", "Contract", "Revnue"))
      m = m + 1
      If sh.Name = "Summary" Then
         ks = 3
         js = 17
         lh = 1
      ElseIf sh.Name = "Contract" Then
         ks = 2
         js = 9
         lh = 6
      ElseIf sh.Name = "Revnue" Then
         ks = 2
         js = 10
         lh = 8
      End If
      r = sh.Cells(sh.Rows.Count, lh).End(xlUp).Row
      ar = sh.Range(sh.Cells(1, 1), sh.Cells(r, js))
      n = 0
      ReDim br(1 To UBound(ar), 1 To js)
      For i = ks To UBound(ar)
         If Trim(ar(i, lh)) = k Then
            n = n + 1
            For j = 1 To UBound(ar, 2)
                  br(n, j) = ar(i, j)
            Next j
         End If
      Next i
      If m = 1 Then
         sh.Copy
         Set wb = ActiveWorkbook
      Else
         sh.Copy after:=wb.Worksheets(wb.Worksheets.Count)
      End If
      With wb.Worksheets(sh.Name)
         .Range(.Cells(ks, 1), .Cells(r, js)).Borders.LineStyle = 0
         .Range(.Cells(ks, 1), .Cells(r, js)) = Empty
         If n > 0 Then
            .Cells(ks, 1).Resize(n, UBound(br, 2)) = br
            .Cells(ks, 1).Resize(n, UBound(br, 2)).Borders.LineStyle = 1
         End If
      End With
Next sh
wb.SaveAs Filename:=ThisWorkbook.Path & "\拆分文件\" & k & ".xlsx"
wb.Close
Next k
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160 · 发表于 2023-10-12 15:18

仅供参考

拆分.rar (35.15 KB, 下载次数: 7)

		自动登录	找回密码
密码			免费注册

[求助] 工作簿按明细sheet的固定字段进行拆分，如何自动化实现

评分